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 #define DEBUG
 193 #ifdef DEBUG
 194       call enerprint(energia,fact)
 195 #endif
 196 #undef DEBUG
 197       if (calc_grad) then
 198 C
 199 C Sum up the components of the Cartesian gradient.
 200 C
 201 #ifdef SPLITELE
 202       do i=1,nct
 203         do j=1,3
 204           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 205      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 206      &                wbond*gradb(j,i)+
 207      &                wstrain*ghpbc(j,i)+
 208      &                wcorr*fact(3)*gradcorr(j,i)+
 209      &                wel_loc*fact(2)*gel_loc(j,i)+
 210      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 211      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 212      &                wcorr5*fact(4)*gradcorr5(j,i)+
 213      &                wcorr6*fact(5)*gradcorr6(j,i)+
 214      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 215      &                wsccor*fact(2)*gsccorc(j,i)
 216      &               +wliptran*gliptranc(j,i)
 217           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 218      &                  wbond*gradbx(j,i)+
 219      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 220      &                  wsccor*fact(2)*gsccorx(j,i)
 221         enddo
 222 #else
 223       do i=1,nct
 224         do j=1,3
 225           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 226      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 227      &                wbond*gradb(j,i)+
 228      &                wcorr*fact(3)*gradcorr(j,i)+
 229      &                wel_loc*fact(2)*gel_loc(j,i)+
 230      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 231      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 232      &                wcorr5*fact(4)*gradcorr5(j,i)+
 233      &                wcorr6*fact(5)*gradcorr6(j,i)+
 234      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 235      &                wsccor*fact(2)*gsccorc(j,i)
 236      &               +wliptran*gliptranc(j,i)
 237           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 238      &                  wbond*gradbx(j,i)+
 239      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 240      &                  wsccor*fact(1)*gsccorx(j,i)
 241      &                 +wliptran*gliptranx(j,i)
 242         enddo
 243 #endif
 244       enddo
 245
 246
 247       do i=1,nres-3
 248         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 249      &   +wcorr5*fact(4)*g_corr5_loc(i)
 250      &   +wcorr6*fact(5)*g_corr6_loc(i)
 251      &   +wturn4*fact(3)*gel_loc_turn4(i)
 252      &   +wturn3*fact(2)*gel_loc_turn3(i)
 253      &   +wturn6*fact(5)*gel_loc_turn6(i)
 254      &   +wel_loc*fact(2)*gel_loc_loc(i)
 255 c     &   +wsccor*fact(1)*gsccor_loc(i)
 256 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 257       enddo
 258       endif
 259       if (dyn_ss) call dyn_set_nss
 260       return
 261       end
 262 C------------------------------------------------------------------------
 263       subroutine enerprint(energia,fact)
 264       implicit real*8 (a-h,o-z)
 265       include 'DIMENSIONS'
 266       include 'DIMENSIONS.ZSCOPT'
 267       include 'COMMON.IOUNITS'
 268       include 'COMMON.FFIELD'
 269       include 'COMMON.SBRIDGE'
 270       double precision energia(0:max_ene),fact(6)
 271       etot=energia(0)
 272       evdw=energia(1)+fact(6)*energia(21)
 273 #ifdef SCP14
 274       evdw2=energia(2)+energia(17)
 275 #else
 276       evdw2=energia(2)
 277 #endif
 278       ees=energia(3)
 279 #ifdef SPLITELE
 280       evdw1=energia(16)
 281 #endif
 282       ecorr=energia(4)
 283       ecorr5=energia(5)
 284       ecorr6=energia(6)
 285       eel_loc=energia(7)
 286       eello_turn3=energia(8)
 287       eello_turn4=energia(9)
 288       eello_turn6=energia(10)
 289       ebe=energia(11)
 290       escloc=energia(12)
 291       etors=energia(13)
 292       etors_d=energia(14)
 293       ehpb=energia(15)
 294       esccor=energia(19)
 295       edihcnstr=energia(20)
 296       estr=energia(18)
 297       ehomology_constr=energia(22)
 298 #ifdef SPLITELE
 299       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 300      &  wvdwpp,
 301      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 302      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 303      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 304      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 305      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 306      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,etot
 307    10 format (/'Virtual-chain energies:'//
 308      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 309      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 310      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 311      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 312      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 313      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 314      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 315      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 316      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 317      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 318      & ' (SS bridges & dist. cnstr.)'/
 319      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 320      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 321      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 322      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 323      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 324      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 325      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 326      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 327      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 328      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 329      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 330      & 'ETOT=  ',1pE16.6,' (total)')
 331 #else
 332       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 333      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 334      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 335      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 336      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 337      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 338      &  edihcnstr,ehomology_constr,ebr*nss,
 339      &  etot
 340    10 format (/'Virtual-chain energies:'//
 341      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 342      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 343      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 344      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 345      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 346      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 347      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 348      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 349      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 350      & ' (SS bridges & dist. cnstr.)'/
 351      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 352      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 353      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 354      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 355      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 356      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 357      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 358      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 359      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 360      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 361      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 362      & 'ETOT=  ',1pE16.6,' (total)')
 363 #endif
 364       return
 365       end
 366 C-----------------------------------------------------------------------
 367       subroutine elj(evdw,evdw_t)
 368 C
 369 C This subroutine calculates the interaction energy of nonbonded side chains
 370 C assuming the LJ potential of interaction.
 371 C
 372       implicit real*8 (a-h,o-z)
 373       include 'DIMENSIONS'
 374       include 'DIMENSIONS.ZSCOPT'
 375       include "DIMENSIONS.COMPAR"
 376       parameter (accur=1.0d-10)
 377       include 'COMMON.GEO'
 378       include 'COMMON.VAR'
 379       include 'COMMON.LOCAL'
 380       include 'COMMON.CHAIN'
 381       include 'COMMON.DERIV'
 382       include 'COMMON.INTERACT'
 383       include 'COMMON.TORSION'
 384       include 'COMMON.ENEPS'
 385       include 'COMMON.SBRIDGE'
 386       include 'COMMON.NAMES'
 387       include 'COMMON.IOUNITS'
 388       include 'COMMON.CONTACTS'
 389       dimension gg(3)
 390       integer icant
 391       external icant
 392 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 393       do i=1,210
 394         do j=1,2
 395           eneps_temp(j,i)=0.0d0
 396         enddo
 397       enddo
 398       evdw=0.0D0
 399       evdw_t=0.0d0
 400       do i=iatsc_s,iatsc_e
 401         itypi=iabs(itype(i))
 402         if (itypi.eq.ntyp1) cycle
 403         itypi1=iabs(itype(i+1))
 404         xi=c(1,nres+i)
 405         yi=c(2,nres+i)
 406         zi=c(3,nres+i)
 407 C Change 12/1/95
 408         num_conti=0
 409 C
 410 C Calculate SC interaction energy.
 411 C
 412         do iint=1,nint_gr(i)
 413 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 414 cd   &                  'iend=',iend(i,iint)
 415           do j=istart(i,iint),iend(i,iint)
 416             itypj=iabs(itype(j))
 417             if (itypj.eq.ntyp1) cycle
 418             xj=c(1,nres+j)-xi
 419             yj=c(2,nres+j)-yi
 420             zj=c(3,nres+j)-zi
 421 C Change 12/1/95 to calculate four-body interactions
 422             rij=xj*xj+yj*yj+zj*zj
 423             rrij=1.0D0/rij
 424 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 425             eps0ij=eps(itypi,itypj)
 426             fac=rrij**expon2
 427             e1=fac*fac*aa
 428             e2=fac*bb
 429             evdwij=e1+e2
 430             ij=icant(itypi,itypj)
 431             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 432             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 433 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 434 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 435 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 436 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 437 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 438 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 439             if (bb.gt.0.0d0) then
 440               evdw=evdw+evdwij
 441             else
 442               evdw_t=evdw_t+evdwij
 443             endif
 444             if (calc_grad) then
 445 C
 446 C Calculate the components of the gradient in DC and X
 447 C
 448             fac=-rrij*(e1+evdwij)
 449             gg(1)=xj*fac
 450             gg(2)=yj*fac
 451             gg(3)=zj*fac
 452             do k=1,3
 453               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 454               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 455             enddo
 456             do k=i,j-1
 457               do l=1,3
 458                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 459               enddo
 460             enddo
 461             endif
 462 C
 463 C 12/1/95, revised on 5/20/97
 464 C
 465 C Calculate the contact function. The ith column of the array JCONT will
 466 C contain the numbers of atoms that make contacts with the atom I (of numbers
 467 C greater than I). The arrays FACONT and GACONT will contain the values of
 468 C the contact function and its derivative.
 469 C
 470 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 471 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 472 C Uncomment next line, if the correlation interactions are contact function only
 473             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 474               rij=dsqrt(rij)
 475               sigij=sigma(itypi,itypj)
 476               r0ij=rs0(itypi,itypj)
 477 C
 478 C Check whether the SC's are not too far to make a contact.
 479 C
 480               rcut=1.5d0*r0ij
 481               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 482 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 483 C
 484               if (fcont.gt.0.0D0) then
 485 C If the SC-SC distance if close to sigma, apply spline.
 486 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 487 cAdam &             fcont1,fprimcont1)
 488 cAdam           fcont1=1.0d0-fcont1
 489 cAdam           if (fcont1.gt.0.0d0) then
 490 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 491 cAdam             fcont=fcont*fcont1
 492 cAdam           endif
 493 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 494 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 495 cga             do k=1,3
 496 cga               gg(k)=gg(k)*eps0ij
 497 cga             enddo
 498 cga             eps0ij=-evdwij*eps0ij
 499 C Uncomment for AL's type of SC correlation interactions.
 500 cadam           eps0ij=-evdwij
 501                 num_conti=num_conti+1
 502                 jcont(num_conti,i)=j
 503                 facont(num_conti,i)=fcont*eps0ij
 504                 fprimcont=eps0ij*fprimcont/rij
 505                 fcont=expon*fcont
 506 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 507 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 508 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 509 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 510                 gacont(1,num_conti,i)=-fprimcont*xj
 511                 gacont(2,num_conti,i)=-fprimcont*yj
 512                 gacont(3,num_conti,i)=-fprimcont*zj
 513 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 514 cd              write (iout,'(2i3,3f10.5)')
 515 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 516               endif
 517             endif
 518           enddo      ! j
 519         enddo        ! iint
 520 C Change 12/1/95
 521         num_cont(i)=num_conti
 522       enddo          ! i
 523       if (calc_grad) then
 524       do i=1,nct
 525         do j=1,3
 526           gvdwc(j,i)=expon*gvdwc(j,i)
 527           gvdwx(j,i)=expon*gvdwx(j,i)
 528         enddo
 529       enddo
 530       endif
 531 C******************************************************************************
 532 C
 533 C                              N O T E !!!
 534 C
 535 C To save time, the factor of EXPON has been extracted from ALL components
 536 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 537 C use!
 538 C
 539 C******************************************************************************
 540       return
 541       end
 542 C-----------------------------------------------------------------------------
 543       subroutine eljk(evdw,evdw_t)
 544 C
 545 C This subroutine calculates the interaction energy of nonbonded side chains
 546 C assuming the LJK potential of interaction.
 547 C
 548       implicit real*8 (a-h,o-z)
 549       include 'DIMENSIONS'
 550       include 'DIMENSIONS.ZSCOPT'
 551       include "DIMENSIONS.COMPAR"
 552       include 'COMMON.GEO'
 553       include 'COMMON.VAR'
 554       include 'COMMON.LOCAL'
 555       include 'COMMON.CHAIN'
 556       include 'COMMON.DERIV'
 557       include 'COMMON.INTERACT'
 558       include 'COMMON.ENEPS'
 559       include 'COMMON.IOUNITS'
 560       include 'COMMON.NAMES'
 561       dimension gg(3)
 562       logical scheck
 563       integer icant
 564       external icant
 565 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 566       do i=1,210
 567         do j=1,2
 568           eneps_temp(j,i)=0.0d0
 569         enddo
 570       enddo
 571       evdw=0.0D0
 572       evdw_t=0.0d0
 573       do i=iatsc_s,iatsc_e
 574         itypi=iabs(itype(i))
 575         if (itypi.eq.ntyp1) cycle
 576         itypi1=iabs(itype(i+1))
 577         xi=c(1,nres+i)
 578         yi=c(2,nres+i)
 579         zi=c(3,nres+i)
 580 C
 581 C Calculate SC interaction energy.
 582 C
 583         do iint=1,nint_gr(i)
 584           do j=istart(i,iint),iend(i,iint)
 585             itypj=iabs(itype(j))
 586             if (itypj.eq.ntyp1) cycle
 587             xj=c(1,nres+j)-xi
 588             yj=c(2,nres+j)-yi
 589             zj=c(3,nres+j)-zi
 590             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 591             fac_augm=rrij**expon
 592             e_augm=augm(itypi,itypj)*fac_augm
 593             r_inv_ij=dsqrt(rrij)
 594             rij=1.0D0/r_inv_ij
 595             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 596             fac=r_shift_inv**expon
 597             e1=fac*fac*aa
 598             e2=fac*bb
 599             evdwij=e_augm+e1+e2
 600             ij=icant(itypi,itypj)
 601             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 602      &        /dabs(eps(itypi,itypj))
 603             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 604 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 605 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 606 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 607 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 608 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 609 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 610 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 611             if (bb.gt.0.0d0) then
 612               evdw=evdw+evdwij
 613             else
 614               evdw_t=evdw_t+evdwij
 615             endif
 616             if (calc_grad) then
 617 C
 618 C Calculate the components of the gradient in DC and X
 619 C
 620             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 621             gg(1)=xj*fac
 622             gg(2)=yj*fac
 623             gg(3)=zj*fac
 624             do k=1,3
 625               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 626               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 627             enddo
 628             do k=i,j-1
 629               do l=1,3
 630                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 631               enddo
 632             enddo
 633             endif
 634           enddo      ! j
 635         enddo        ! iint
 636       enddo          ! i
 637       if (calc_grad) then
 638       do i=1,nct
 639         do j=1,3
 640           gvdwc(j,i)=expon*gvdwc(j,i)
 641           gvdwx(j,i)=expon*gvdwx(j,i)
 642         enddo
 643       enddo
 644       endif
 645       return
 646       end
 647 C-----------------------------------------------------------------------------
 648       subroutine ebp(evdw,evdw_t)
 649 C
 650 C This subroutine calculates the interaction energy of nonbonded side chains
 651 C assuming the Berne-Pechukas potential of interaction.
 652 C
 653       implicit real*8 (a-h,o-z)
 654       include 'DIMENSIONS'
 655       include 'DIMENSIONS.ZSCOPT'
 656       include "DIMENSIONS.COMPAR"
 657       include 'COMMON.GEO'
 658       include 'COMMON.VAR'
 659       include 'COMMON.LOCAL'
 660       include 'COMMON.CHAIN'
 661       include 'COMMON.DERIV'
 662       include 'COMMON.NAMES'
 663       include 'COMMON.INTERACT'
 664       include 'COMMON.ENEPS'
 665       include 'COMMON.IOUNITS'
 666       include 'COMMON.CALC'
 667       common /srutu/ icall
 668 c     double precision rrsave(maxdim)
 669       logical lprn
 670       integer icant
 671       external icant
 672       do i=1,210
 673         do j=1,2
 674           eneps_temp(j,i)=0.0d0
 675         enddo
 676       enddo
 677       evdw=0.0D0
 678       evdw_t=0.0d0
 679 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 680 c     if (icall.eq.0) then
 681 c       lprn=.true.
 682 c     else
 683         lprn=.false.
 684 c     endif
 685       ind=0
 686       do i=iatsc_s,iatsc_e
 687         itypi=iabs(itype(i))
 688         if (itypi.eq.ntyp1) cycle
 689         itypi1=iabs(itype(i+1))
 690         xi=c(1,nres+i)
 691         yi=c(2,nres+i)
 692         zi=c(3,nres+i)
 693         dxi=dc_norm(1,nres+i)
 694         dyi=dc_norm(2,nres+i)
 695         dzi=dc_norm(3,nres+i)
 696         dsci_inv=vbld_inv(i+nres)
 697 C
 698 C Calculate SC interaction energy.
 699 C
 700         do iint=1,nint_gr(i)
 701           do j=istart(i,iint),iend(i,iint)
 702             ind=ind+1
 703             itypj=iabs(itype(j))
 704             if (itypj.eq.ntyp1) cycle
 705             dscj_inv=vbld_inv(j+nres)
 706             chi1=chi(itypi,itypj)
 707             chi2=chi(itypj,itypi)
 708             chi12=chi1*chi2
 709             chip1=chip(itypi)
 710             chip2=chip(itypj)
 711             chip12=chip1*chip2
 712             alf1=alp(itypi)
 713             alf2=alp(itypj)
 714             alf12=0.5D0*(alf1+alf2)
 715 C For diagnostics only!!!
 716 c           chi1=0.0D0
 717 c           chi2=0.0D0
 718 c           chi12=0.0D0
 719 c           chip1=0.0D0
 720 c           chip2=0.0D0
 721 c           chip12=0.0D0
 722 c           alf1=0.0D0
 723 c           alf2=0.0D0
 724 c           alf12=0.0D0
 725             xj=c(1,nres+j)-xi
 726             yj=c(2,nres+j)-yi
 727             zj=c(3,nres+j)-zi
 728             dxj=dc_norm(1,nres+j)
 729             dyj=dc_norm(2,nres+j)
 730             dzj=dc_norm(3,nres+j)
 731             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 732 cd          if (icall.eq.0) then
 733 cd            rrsave(ind)=rrij
 734 cd          else
 735 cd            rrij=rrsave(ind)
 736 cd          endif
 737             rij=dsqrt(rrij)
 738 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 739             call sc_angular
 740 C Calculate whole angle-dependent part of epsilon and contributions
 741 C to its derivatives
 742             fac=(rrij*sigsq)**expon2
 743             e1=fac*fac*aa
 744             e2=fac*bb
 745             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 746             eps2der=evdwij*eps3rt
 747             eps3der=evdwij*eps2rt
 748             evdwij=evdwij*eps2rt*eps3rt
 749             ij=icant(itypi,itypj)
 750             aux=eps1*eps2rt**2*eps3rt**2
 751             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 752      &        /dabs(eps(itypi,itypj))
 753             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 754             if (bb.gt.0.0d0) then
 755               evdw=evdw+evdwij
 756             else
 757               evdw_t=evdw_t+evdwij
 758             endif
 759             if (calc_grad) then
 760             if (lprn) then
 761             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 762             epsi=bb**2/aa
 763             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 764      &        restyp(itypi),i,restyp(itypj),j,
 765      &        epsi,sigm,chi1,chi2,chip1,chip2,
 766      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 767      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 768      &        evdwij
 769             endif
 770 C Calculate gradient components.
 771             e1=e1*eps1*eps2rt**2*eps3rt**2
 772             fac=-expon*(e1+evdwij)
 773             sigder=fac/sigsq
 774             fac=rrij*fac
 775 C Calculate radial part of the gradient
 776             gg(1)=xj*fac
 777             gg(2)=yj*fac
 778             gg(3)=zj*fac
 779 C Calculate the angular part of the gradient and sum add the contributions
 780 C to the appropriate components of the Cartesian gradient.
 781             call sc_grad
 782             endif
 783           enddo      ! j
 784         enddo        ! iint
 785       enddo          ! i
 786 c     stop
 787       return
 788       end
 789 C-----------------------------------------------------------------------------
 790       subroutine egb(evdw,evdw_t)
 791 C
 792 C This subroutine calculates the interaction energy of nonbonded side chains
 793 C assuming the Gay-Berne potential of interaction.
 794 C
 795       implicit real*8 (a-h,o-z)
 796       include 'DIMENSIONS'
 797       include 'DIMENSIONS.ZSCOPT'
 798       include "DIMENSIONS.COMPAR"
 799       include 'COMMON.GEO'
 800       include 'COMMON.VAR'
 801       include 'COMMON.LOCAL'
 802       include 'COMMON.CHAIN'
 803       include 'COMMON.DERIV'
 804       include 'COMMON.NAMES'
 805       include 'COMMON.INTERACT'
 806       include 'COMMON.ENEPS'
 807       include 'COMMON.IOUNITS'
 808       include 'COMMON.CALC'
 809       include 'COMMON.SBRIDGE'
 810       logical lprn
 811       common /srutu/icall
 812       integer icant,xshift,yshift,zshift
 813       external icant
 814       do i=1,210
 815         do j=1,2
 816           eneps_temp(j,i)=0.0d0
 817         enddo
 818       enddo
 819 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 820       evdw=0.0D0
 821       evdw_t=0.0d0
 822       lprn=.false.
 823 c      if (icall.gt.0) lprn=.true.
 824       ind=0
 825       do i=iatsc_s,iatsc_e
 826         itypi=iabs(itype(i))
 827         if (itypi.eq.ntyp1) cycle
 828         itypi1=iabs(itype(i+1))
 829         xi=c(1,nres+i)
 830         yi=c(2,nres+i)
 831         zi=c(3,nres+i)
 832 C returning the ith atom to box
 833           xi=mod(xi,boxxsize)
 834           if (xi.lt.0) xi=xi+boxxsize
 835           yi=mod(yi,boxysize)
 836           if (yi.lt.0) yi=yi+boxysize
 837           zi=mod(zi,boxzsize)
 838           if (zi.lt.0) zi=zi+boxzsize
 839        if ((zi.gt.bordlipbot)
 840      &.and.(zi.lt.bordliptop)) then
 841 C the energy transfer exist
 842         if (zi.lt.buflipbot) then
 843 C what fraction I am in
 844          fracinbuf=1.0d0-
 845      &        ((zi-bordlipbot)/lipbufthick)
 846 C lipbufthick is thickenes of lipid buffore
 847          sslipi=sscalelip(fracinbuf)
 848          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 849         elseif (zi.gt.bufliptop) then
 850          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 851          sslipi=sscalelip(fracinbuf)
 852          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 853         else
 854          sslipi=1.0d0
 855          ssgradlipi=0.0
 856         endif
 857        else
 858          sslipi=0.0d0
 859          ssgradlipi=0.0
 860        endif
 861
 862         dxi=dc_norm(1,nres+i)
 863         dyi=dc_norm(2,nres+i)
 864         dzi=dc_norm(3,nres+i)
 865         dsci_inv=vbld_inv(i+nres)
 866 C
 867 C Calculate SC interaction energy.
 868 C
 869         do iint=1,nint_gr(i)
 870           do j=istart(i,iint),iend(i,iint)
 871             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 872               call dyn_ssbond_ene(i,j,evdwij)
 873               evdw=evdw+evdwij
 874 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 875 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 876 C triple bond artifac removal
 877              do k=j+1,iend(i,iint)
 878 C search over all next residues
 879               if (dyn_ss_mask(k)) then
 880 C check if they are cysteins
 881 C              write(iout,*) 'k=',k
 882               call triple_ssbond_ene(i,j,k,evdwij)
 883 C call the energy function that removes the artifical triple disulfide
 884 C bond the soubroutine is located in ssMD.F
 885               evdw=evdw+evdwij
 886 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 887 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 888               endif!dyn_ss_mask(k)
 889              enddo! k
 890             ELSE
 891             ind=ind+1
 892             itypj=iabs(itype(j))
 893             if (itypj.eq.ntyp1) cycle
 894             dscj_inv=vbld_inv(j+nres)
 895             sig0ij=sigma(itypi,itypj)
 896             chi1=chi(itypi,itypj)
 897             chi2=chi(itypj,itypi)
 898             chi12=chi1*chi2
 899             chip1=chip(itypi)
 900             chip2=chip(itypj)
 901             chip12=chip1*chip2
 902             alf1=alp(itypi)
 903             alf2=alp(itypj)
 904             alf12=0.5D0*(alf1+alf2)
 905 C For diagnostics only!!!
 906 c           chi1=0.0D0
 907 c           chi2=0.0D0
 908 c           chi12=0.0D0
 909 c           chip1=0.0D0
 910 c           chip2=0.0D0
 911 c           chip12=0.0D0
 912 c           alf1=0.0D0
 913 c           alf2=0.0D0
 914 c           alf12=0.0D0
 915             xj=c(1,nres+j)
 916             yj=c(2,nres+j)
 917             zj=c(3,nres+j)
 918 C returning jth atom to box
 919           xj=mod(xj,boxxsize)
 920           if (xj.lt.0) xj=xj+boxxsize
 921           yj=mod(yj,boxysize)
 922           if (yj.lt.0) yj=yj+boxysize
 923           zj=mod(zj,boxzsize)
 924           if (zj.lt.0) zj=zj+boxzsize
 925        if ((zj.gt.bordlipbot)
 926      &.and.(zj.lt.bordliptop)) then
 927 C the energy transfer exist
 928         if (zj.lt.buflipbot) then
 929 C what fraction I am in
 930          fracinbuf=1.0d0-
 931      &        ((zj-bordlipbot)/lipbufthick)
 932 C lipbufthick is thickenes of lipid buffore
 933          sslipj=sscalelip(fracinbuf)
 934          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 935         elseif (zj.gt.bufliptop) then
 936          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 937          sslipj=sscalelip(fracinbuf)
 938          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 939         else
 940          sslipj=1.0d0
 941          ssgradlipj=0.0
 942         endif
 943        else
 944          sslipj=0.0d0
 945          ssgradlipj=0.0
 946        endif
 947       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 948      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 949       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 950      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 951 C       if (aa.ne.aa_aq(itypi,itypj)) then
 952
 953 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
 954 C     & bb_aq(itypi,itypj)-bb,
 955 C     & sslipi,sslipj
 956 C         endif
 957
 958 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 959 C checking the distance
 960       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 961       xj_safe=xj
 962       yj_safe=yj
 963       zj_safe=zj
 964       subchap=0
 965 C finding the closest
 966       do xshift=-1,1
 967       do yshift=-1,1
 968       do zshift=-1,1
 969           xj=xj_safe+xshift*boxxsize
 970           yj=yj_safe+yshift*boxysize
 971           zj=zj_safe+zshift*boxzsize
 972           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 973           if(dist_temp.lt.dist_init) then
 974             dist_init=dist_temp
 975             xj_temp=xj
 976             yj_temp=yj
 977             zj_temp=zj
 978             subchap=1
 979           endif
 980        enddo
 981        enddo
 982        enddo
 983        if (subchap.eq.1) then
 984           xj=xj_temp-xi
 985           yj=yj_temp-yi
 986           zj=zj_temp-zi
 987        else
 988           xj=xj_safe-xi
 989           yj=yj_safe-yi
 990           zj=zj_safe-zi
 991        endif
 992
 993             dxj=dc_norm(1,nres+j)
 994             dyj=dc_norm(2,nres+j)
 995             dzj=dc_norm(3,nres+j)
 996 c            write (iout,*) i,j,xj,yj,zj
 997             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 998             rij=dsqrt(rrij)
 999             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1000             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1001             if (sss.le.0.0) cycle
1002 C Calculate angle-dependent terms of energy and contributions to their
1003 C derivatives.
1004
1005             call sc_angular
1006             sigsq=1.0D0/sigsq
1007             sig=sig0ij*dsqrt(sigsq)
1008             rij_shift=1.0D0/rij-sig+sig0ij
1009 C I hate to put IF's in the loops, but here don't have another choice!!!!
1010             if (rij_shift.le.0.0D0) then
1011               evdw=1.0D20
1012               return
1013             endif
1014             sigder=-sig*sigsq
1015 c---------------------------------------------------------------
1016             rij_shift=1.0D0/rij_shift
1017             fac=rij_shift**expon
1018             e1=fac*fac*aa
1019             e2=fac*bb
1020             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1021             eps2der=evdwij*eps3rt
1022             eps3der=evdwij*eps2rt
1023             evdwij=evdwij*eps2rt*eps3rt
1024             if (bb.gt.0) then
1025               evdw=evdw+evdwij*sss
1026             else
1027               evdw_t=evdw_t+evdwij*sss
1028             endif
1029             ij=icant(itypi,itypj)
1030             aux=eps1*eps2rt**2*eps3rt**2
1031             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1032      &        /dabs(eps(itypi,itypj))
1033             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1034 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1035 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1036 c     &         aux*e2/eps(itypi,itypj)
1037 c            if (lprn) then
1038             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1039             epsi=bb**2/aa
1040 C#define DEBUG
1041 #ifdef DEBUG
1042             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1043      &        restyp(itypi),i,restyp(itypj),j,
1044      &        epsi,sigm,chi1,chi2,chip1,chip2,
1045      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1046      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1047      &        evdwij
1048              write (iout,*) "partial sum", evdw, evdw_t
1049 #endif
1050 C#undef DEBUG
1051 c            endif
1052             if (calc_grad) then
1053 C Calculate gradient components.
1054             e1=e1*eps1*eps2rt**2*eps3rt**2
1055             fac=-expon*(e1+evdwij)*rij_shift
1056             sigder=fac*sigder
1057             fac=rij*fac
1058             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1059 C Calculate the radial part of the gradient
1060             gg(1)=xj*fac
1061             gg(2)=yj*fac
1062             gg(3)=zj*fac
1063 C Calculate angular part of the gradient.
1064             call sc_grad
1065             endif
1066 C            write(iout,*)  "partial sum", evdw, evdw_t
1067             ENDIF    ! dyn_ss
1068           enddo      ! j
1069         enddo        ! iint
1070       enddo          ! i
1071       return
1072       end
1073 C-----------------------------------------------------------------------------
1074       subroutine egbv(evdw,evdw_t)
1075 C
1076 C This subroutine calculates the interaction energy of nonbonded side chains
1077 C assuming the Gay-Berne-Vorobjev potential of interaction.
1078 C
1079       implicit real*8 (a-h,o-z)
1080       include 'DIMENSIONS'
1081       include 'DIMENSIONS.ZSCOPT'
1082       include "DIMENSIONS.COMPAR"
1083       include 'COMMON.GEO'
1084       include 'COMMON.VAR'
1085       include 'COMMON.LOCAL'
1086       include 'COMMON.CHAIN'
1087       include 'COMMON.DERIV'
1088       include 'COMMON.NAMES'
1089       include 'COMMON.INTERACT'
1090       include 'COMMON.ENEPS'
1091       include 'COMMON.IOUNITS'
1092       include 'COMMON.CALC'
1093       common /srutu/ icall
1094       logical lprn
1095       integer icant
1096       external icant
1097       do i=1,210
1098         do j=1,2
1099           eneps_temp(j,i)=0.0d0
1100         enddo
1101       enddo
1102       evdw=0.0D0
1103       evdw_t=0.0d0
1104 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1105       evdw=0.0D0
1106       lprn=.false.
1107 c      if (icall.gt.0) lprn=.true.
1108       ind=0
1109       do i=iatsc_s,iatsc_e
1110         itypi=iabs(itype(i))
1111         if (itypi.eq.ntyp1) cycle
1112         itypi1=iabs(itype(i+1))
1113         xi=c(1,nres+i)
1114         yi=c(2,nres+i)
1115         zi=c(3,nres+i)
1116         dxi=dc_norm(1,nres+i)
1117         dyi=dc_norm(2,nres+i)
1118         dzi=dc_norm(3,nres+i)
1119         dsci_inv=vbld_inv(i+nres)
1120 C
1121 C Calculate SC interaction energy.
1122 C
1123         do iint=1,nint_gr(i)
1124           do j=istart(i,iint),iend(i,iint)
1125             ind=ind+1
1126             itypj=iabs(itype(j))
1127             if (itypj.eq.ntyp1) cycle
1128             dscj_inv=vbld_inv(j+nres)
1129             sig0ij=sigma(itypi,itypj)
1130             r0ij=r0(itypi,itypj)
1131             chi1=chi(itypi,itypj)
1132             chi2=chi(itypj,itypi)
1133             chi12=chi1*chi2
1134             chip1=chip(itypi)
1135             chip2=chip(itypj)
1136             chip12=chip1*chip2
1137             alf1=alp(itypi)
1138             alf2=alp(itypj)
1139             alf12=0.5D0*(alf1+alf2)
1140 C For diagnostics only!!!
1141 c           chi1=0.0D0
1142 c           chi2=0.0D0
1143 c           chi12=0.0D0
1144 c           chip1=0.0D0
1145 c           chip2=0.0D0
1146 c           chip12=0.0D0
1147 c           alf1=0.0D0
1148 c           alf2=0.0D0
1149 c           alf12=0.0D0
1150             xj=c(1,nres+j)-xi
1151             yj=c(2,nres+j)-yi
1152             zj=c(3,nres+j)-zi
1153             dxj=dc_norm(1,nres+j)
1154             dyj=dc_norm(2,nres+j)
1155             dzj=dc_norm(3,nres+j)
1156             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1157             rij=dsqrt(rrij)
1158 C Calculate angle-dependent terms of energy and contributions to their
1159 C derivatives.
1160             call sc_angular
1161             sigsq=1.0D0/sigsq
1162             sig=sig0ij*dsqrt(sigsq)
1163             rij_shift=1.0D0/rij-sig+r0ij
1164 C I hate to put IF's in the loops, but here don't have another choice!!!!
1165             if (rij_shift.le.0.0D0) then
1166               evdw=1.0D20
1167               return
1168             endif
1169             sigder=-sig*sigsq
1170 c---------------------------------------------------------------
1171             rij_shift=1.0D0/rij_shift
1172             fac=rij_shift**expon
1173             e1=fac*fac*aa
1174             e2=fac*bb
1175             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1176             eps2der=evdwij*eps3rt
1177             eps3der=evdwij*eps2rt
1178             fac_augm=rrij**expon
1179             e_augm=augm(itypi,itypj)*fac_augm
1180             evdwij=evdwij*eps2rt*eps3rt
1181             if (bb.gt.0.0d0) then
1182               evdw=evdw+evdwij+e_augm
1183             else
1184               evdw_t=evdw_t+evdwij+e_augm
1185             endif
1186             ij=icant(itypi,itypj)
1187             aux=eps1*eps2rt**2*eps3rt**2
1188             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1189      &        /dabs(eps(itypi,itypj))
1190             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1191 c            eneps_temp(ij)=eneps_temp(ij)
1192 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1193 c            if (lprn) then
1194 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1195 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1196 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1197 c     &        restyp(itypi),i,restyp(itypj),j,
1198 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1199 c     &        chi1,chi2,chip1,chip2,
1200 c     &        eps1,eps2rt**2,eps3rt**2,
1201 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1202 c     &        evdwij+e_augm
1203 c            endif
1204             if (calc_grad) then
1205 C Calculate gradient components.
1206             e1=e1*eps1*eps2rt**2*eps3rt**2
1207             fac=-expon*(e1+evdwij)*rij_shift
1208             sigder=fac*sigder
1209             fac=rij*fac-2*expon*rrij*e_augm
1210 C Calculate the radial part of the gradient
1211             gg(1)=xj*fac
1212             gg(2)=yj*fac
1213             gg(3)=zj*fac
1214 C Calculate angular part of the gradient.
1215             call sc_grad
1216             endif
1217           enddo      ! j
1218         enddo        ! iint
1219       enddo          ! i
1220       return
1221       end
1222 C-----------------------------------------------------------------------------
1223       subroutine sc_angular
1224 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1225 C om12. Called by ebp, egb, and egbv.
1226       implicit none
1227       include 'COMMON.CALC'
1228       erij(1)=xj*rij
1229       erij(2)=yj*rij
1230       erij(3)=zj*rij
1231       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1232       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1233       om12=dxi*dxj+dyi*dyj+dzi*dzj
1234       chiom12=chi12*om12
1235 C Calculate eps1(om12) and its derivative in om12
1236       faceps1=1.0D0-om12*chiom12
1237       faceps1_inv=1.0D0/faceps1
1238       eps1=dsqrt(faceps1_inv)
1239 C Following variable is eps1*deps1/dom12
1240       eps1_om12=faceps1_inv*chiom12
1241 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1242 C and om12.
1243       om1om2=om1*om2
1244       chiom1=chi1*om1
1245       chiom2=chi2*om2
1246       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1247       sigsq=1.0D0-facsig*faceps1_inv
1248       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1249       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1250       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1251 C Calculate eps2 and its derivatives in om1, om2, and om12.
1252       chipom1=chip1*om1
1253       chipom2=chip2*om2
1254       chipom12=chip12*om12
1255       facp=1.0D0-om12*chipom12
1256       facp_inv=1.0D0/facp
1257       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1258 C Following variable is the square root of eps2
1259       eps2rt=1.0D0-facp1*facp_inv
1260 C Following three variables are the derivatives of the square root of eps
1261 C in om1, om2, and om12.
1262       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1263       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1264       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1265 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1266       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1267 C Calculate whole angle-dependent part of epsilon and contributions
1268 C to its derivatives
1269       return
1270       end
1271 C----------------------------------------------------------------------------
1272       subroutine sc_grad
1273       implicit real*8 (a-h,o-z)
1274       include 'DIMENSIONS'
1275       include 'DIMENSIONS.ZSCOPT'
1276       include 'COMMON.CHAIN'
1277       include 'COMMON.DERIV'
1278       include 'COMMON.CALC'
1279       double precision dcosom1(3),dcosom2(3)
1280       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1281       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1282       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1283      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1284       do k=1,3
1285         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1286         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1287       enddo
1288       do k=1,3
1289         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1290       enddo
1291       do k=1,3
1292         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1293      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1294      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1295         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1296      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1297      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1298       enddo
1299 C
1300 C Calculate the components of the gradient in DC and X
1301 C
1302       do k=i,j-1
1303         do l=1,3
1304           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1305         enddo
1306       enddo
1307       return
1308       end
1309 c------------------------------------------------------------------------------
1310       subroutine vec_and_deriv
1311       implicit real*8 (a-h,o-z)
1312       include 'DIMENSIONS'
1313       include 'DIMENSIONS.ZSCOPT'
1314       include 'COMMON.IOUNITS'
1315       include 'COMMON.GEO'
1316       include 'COMMON.VAR'
1317       include 'COMMON.LOCAL'
1318       include 'COMMON.CHAIN'
1319       include 'COMMON.VECTORS'
1320       include 'COMMON.DERIV'
1321       include 'COMMON.INTERACT'
1322       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1323 C Compute the local reference systems. For reference system (i), the
1324 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1325 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1326       do i=1,nres-1
1327 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1328           if (i.eq.nres-1) then
1329 C Case of the last full residue
1330 C Compute the Z-axis
1331             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1332             costh=dcos(pi-theta(nres))
1333             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1334             do k=1,3
1335               uz(k,i)=fac*uz(k,i)
1336             enddo
1337             if (calc_grad) then
1338 C Compute the derivatives of uz
1339             uzder(1,1,1)= 0.0d0
1340             uzder(2,1,1)=-dc_norm(3,i-1)
1341             uzder(3,1,1)= dc_norm(2,i-1)
1342             uzder(1,2,1)= dc_norm(3,i-1)
1343             uzder(2,2,1)= 0.0d0
1344             uzder(3,2,1)=-dc_norm(1,i-1)
1345             uzder(1,3,1)=-dc_norm(2,i-1)
1346             uzder(2,3,1)= dc_norm(1,i-1)
1347             uzder(3,3,1)= 0.0d0
1348             uzder(1,1,2)= 0.0d0
1349             uzder(2,1,2)= dc_norm(3,i)
1350             uzder(3,1,2)=-dc_norm(2,i)
1351             uzder(1,2,2)=-dc_norm(3,i)
1352             uzder(2,2,2)= 0.0d0
1353             uzder(3,2,2)= dc_norm(1,i)
1354             uzder(1,3,2)= dc_norm(2,i)
1355             uzder(2,3,2)=-dc_norm(1,i)
1356             uzder(3,3,2)= 0.0d0
1357             endif
1358 C Compute the Y-axis
1359             facy=fac
1360             do k=1,3
1361               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1362             enddo
1363             if (calc_grad) then
1364 C Compute the derivatives of uy
1365             do j=1,3
1366               do k=1,3
1367                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1368      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1369                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1370               enddo
1371               uyder(j,j,1)=uyder(j,j,1)-costh
1372               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1373             enddo
1374             do j=1,2
1375               do k=1,3
1376                 do l=1,3
1377                   uygrad(l,k,j,i)=uyder(l,k,j)
1378                   uzgrad(l,k,j,i)=uzder(l,k,j)
1379                 enddo
1380               enddo
1381             enddo
1382             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1383             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1384             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1385             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1386             endif
1387           else
1388 C Other residues
1389 C Compute the Z-axis
1390             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1391             costh=dcos(pi-theta(i+2))
1392             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1393             do k=1,3
1394               uz(k,i)=fac*uz(k,i)
1395             enddo
1396             if (calc_grad) then
1397 C Compute the derivatives of uz
1398             uzder(1,1,1)= 0.0d0
1399             uzder(2,1,1)=-dc_norm(3,i+1)
1400             uzder(3,1,1)= dc_norm(2,i+1)
1401             uzder(1,2,1)= dc_norm(3,i+1)
1402             uzder(2,2,1)= 0.0d0
1403             uzder(3,2,1)=-dc_norm(1,i+1)
1404             uzder(1,3,1)=-dc_norm(2,i+1)
1405             uzder(2,3,1)= dc_norm(1,i+1)
1406             uzder(3,3,1)= 0.0d0
1407             uzder(1,1,2)= 0.0d0
1408             uzder(2,1,2)= dc_norm(3,i)
1409             uzder(3,1,2)=-dc_norm(2,i)
1410             uzder(1,2,2)=-dc_norm(3,i)
1411             uzder(2,2,2)= 0.0d0
1412             uzder(3,2,2)= dc_norm(1,i)
1413             uzder(1,3,2)= dc_norm(2,i)
1414             uzder(2,3,2)=-dc_norm(1,i)
1415             uzder(3,3,2)= 0.0d0
1416             endif
1417 C Compute the Y-axis
1418             facy=fac
1419             do k=1,3
1420               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1421             enddo
1422             if (calc_grad) then
1423 C Compute the derivatives of uy
1424             do j=1,3
1425               do k=1,3
1426                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1427      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1428                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1429               enddo
1430               uyder(j,j,1)=uyder(j,j,1)-costh
1431               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1432             enddo
1433             do j=1,2
1434               do k=1,3
1435                 do l=1,3
1436                   uygrad(l,k,j,i)=uyder(l,k,j)
1437                   uzgrad(l,k,j,i)=uzder(l,k,j)
1438                 enddo
1439               enddo
1440             enddo
1441             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1442             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1443             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1444             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1445           endif
1446           endif
1447       enddo
1448       if (calc_grad) then
1449       do i=1,nres-1
1450         vbld_inv_temp(1)=vbld_inv(i+1)
1451         if (i.lt.nres-1) then
1452           vbld_inv_temp(2)=vbld_inv(i+2)
1453         else
1454           vbld_inv_temp(2)=vbld_inv(i)
1455         endif
1456         do j=1,2
1457           do k=1,3
1458             do l=1,3
1459               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1460               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1461             enddo
1462           enddo
1463         enddo
1464       enddo
1465       endif
1466       return
1467       end
1468 C-----------------------------------------------------------------------------
1469       subroutine vec_and_deriv_test
1470       implicit real*8 (a-h,o-z)
1471       include 'DIMENSIONS'
1472       include 'DIMENSIONS.ZSCOPT'
1473       include 'COMMON.IOUNITS'
1474       include 'COMMON.GEO'
1475       include 'COMMON.VAR'
1476       include 'COMMON.LOCAL'
1477       include 'COMMON.CHAIN'
1478       include 'COMMON.VECTORS'
1479       dimension uyder(3,3,2),uzder(3,3,2)
1480 C Compute the local reference systems. For reference system (i), the
1481 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1482 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1483       do i=1,nres-1
1484           if (i.eq.nres-1) then
1485 C Case of the last full residue
1486 C Compute the Z-axis
1487             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1488             costh=dcos(pi-theta(nres))
1489             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1490 c            write (iout,*) 'fac',fac,
1491 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1492             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1493             do k=1,3
1494               uz(k,i)=fac*uz(k,i)
1495             enddo
1496 C Compute the derivatives of uz
1497             uzder(1,1,1)= 0.0d0
1498             uzder(2,1,1)=-dc_norm(3,i-1)
1499             uzder(3,1,1)= dc_norm(2,i-1)
1500             uzder(1,2,1)= dc_norm(3,i-1)
1501             uzder(2,2,1)= 0.0d0
1502             uzder(3,2,1)=-dc_norm(1,i-1)
1503             uzder(1,3,1)=-dc_norm(2,i-1)
1504             uzder(2,3,1)= dc_norm(1,i-1)
1505             uzder(3,3,1)= 0.0d0
1506             uzder(1,1,2)= 0.0d0
1507             uzder(2,1,2)= dc_norm(3,i)
1508             uzder(3,1,2)=-dc_norm(2,i)
1509             uzder(1,2,2)=-dc_norm(3,i)
1510             uzder(2,2,2)= 0.0d0
1511             uzder(3,2,2)= dc_norm(1,i)
1512             uzder(1,3,2)= dc_norm(2,i)
1513             uzder(2,3,2)=-dc_norm(1,i)
1514             uzder(3,3,2)= 0.0d0
1515 C Compute the Y-axis
1516             do k=1,3
1517               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1518             enddo
1519             facy=fac
1520             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1521      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1522      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1523             do k=1,3
1524 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1525               uy(k,i)=
1526 c     &        facy*(
1527      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1528      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1529 c     &        )
1530             enddo
1531 c            write (iout,*) 'facy',facy,
1532 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1533             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1534             do k=1,3
1535               uy(k,i)=facy*uy(k,i)
1536             enddo
1537 C Compute the derivatives of uy
1538             do j=1,3
1539               do k=1,3
1540                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1541      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1542                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1543               enddo
1544 c              uyder(j,j,1)=uyder(j,j,1)-costh
1545 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1546               uyder(j,j,1)=uyder(j,j,1)
1547      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1548               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1549      &          +uyder(j,j,2)
1550             enddo
1551             do j=1,2
1552               do k=1,3
1553                 do l=1,3
1554                   uygrad(l,k,j,i)=uyder(l,k,j)
1555                   uzgrad(l,k,j,i)=uzder(l,k,j)
1556                 enddo
1557               enddo
1558             enddo
1559             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1560             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1561             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1562             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1563           else
1564 C Other residues
1565 C Compute the Z-axis
1566             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1567             costh=dcos(pi-theta(i+2))
1568             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1569             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1570             do k=1,3
1571               uz(k,i)=fac*uz(k,i)
1572             enddo
1573 C Compute the derivatives of uz
1574             uzder(1,1,1)= 0.0d0
1575             uzder(2,1,1)=-dc_norm(3,i+1)
1576             uzder(3,1,1)= dc_norm(2,i+1)
1577             uzder(1,2,1)= dc_norm(3,i+1)
1578             uzder(2,2,1)= 0.0d0
1579             uzder(3,2,1)=-dc_norm(1,i+1)
1580             uzder(1,3,1)=-dc_norm(2,i+1)
1581             uzder(2,3,1)= dc_norm(1,i+1)
1582             uzder(3,3,1)= 0.0d0
1583             uzder(1,1,2)= 0.0d0
1584             uzder(2,1,2)= dc_norm(3,i)
1585             uzder(3,1,2)=-dc_norm(2,i)
1586             uzder(1,2,2)=-dc_norm(3,i)
1587             uzder(2,2,2)= 0.0d0
1588             uzder(3,2,2)= dc_norm(1,i)
1589             uzder(1,3,2)= dc_norm(2,i)
1590             uzder(2,3,2)=-dc_norm(1,i)
1591             uzder(3,3,2)= 0.0d0
1592 C Compute the Y-axis
1593             facy=fac
1594             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1595      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1596      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1597             do k=1,3
1598 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1599               uy(k,i)=
1600 c     &        facy*(
1601      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1602      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1603 c     &        )
1604             enddo
1605 c            write (iout,*) 'facy',facy,
1606 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1607             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1608             do k=1,3
1609               uy(k,i)=facy*uy(k,i)
1610             enddo
1611 C Compute the derivatives of uy
1612             do j=1,3
1613               do k=1,3
1614                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1615      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1616                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1617               enddo
1618 c              uyder(j,j,1)=uyder(j,j,1)-costh
1619 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1620               uyder(j,j,1)=uyder(j,j,1)
1621      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1622               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1623      &          +uyder(j,j,2)
1624             enddo
1625             do j=1,2
1626               do k=1,3
1627                 do l=1,3
1628                   uygrad(l,k,j,i)=uyder(l,k,j)
1629                   uzgrad(l,k,j,i)=uzder(l,k,j)
1630                 enddo
1631               enddo
1632             enddo
1633             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1634             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1635             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1636             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1637           endif
1638       enddo
1639       do i=1,nres-1
1640         do j=1,2
1641           do k=1,3
1642             do l=1,3
1643               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1644               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1645             enddo
1646           enddo
1647         enddo
1648       enddo
1649       return
1650       end
1651 C-----------------------------------------------------------------------------
1652       subroutine check_vecgrad
1653       implicit real*8 (a-h,o-z)
1654       include 'DIMENSIONS'
1655       include 'DIMENSIONS.ZSCOPT'
1656       include 'COMMON.IOUNITS'
1657       include 'COMMON.GEO'
1658       include 'COMMON.VAR'
1659       include 'COMMON.LOCAL'
1660       include 'COMMON.CHAIN'
1661       include 'COMMON.VECTORS'
1662       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1663       dimension uyt(3,maxres),uzt(3,maxres)
1664       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1665       double precision delta /1.0d-7/
1666       call vec_and_deriv
1667 cd      do i=1,nres
1668 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1669 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1670 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1671 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1672 cd     &     (dc_norm(if90,i),if90=1,3)
1673 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1674 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1675 cd          write(iout,'(a)')
1676 cd      enddo
1677       do i=1,nres
1678         do j=1,2
1679           do k=1,3
1680             do l=1,3
1681               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1682               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1683             enddo
1684           enddo
1685         enddo
1686       enddo
1687       call vec_and_deriv
1688       do i=1,nres
1689         do j=1,3
1690           uyt(j,i)=uy(j,i)
1691           uzt(j,i)=uz(j,i)
1692         enddo
1693       enddo
1694       do i=1,nres
1695 cd        write (iout,*) 'i=',i
1696         do k=1,3
1697           erij(k)=dc_norm(k,i)
1698         enddo
1699         do j=1,3
1700           do k=1,3
1701             dc_norm(k,i)=erij(k)
1702           enddo
1703           dc_norm(j,i)=dc_norm(j,i)+delta
1704 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1705 c          do k=1,3
1706 c            dc_norm(k,i)=dc_norm(k,i)/fac
1707 c          enddo
1708 c          write (iout,*) (dc_norm(k,i),k=1,3)
1709 c          write (iout,*) (erij(k),k=1,3)
1710           call vec_and_deriv
1711           do k=1,3
1712             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1713             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1714             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1715             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1716           enddo
1717 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1718 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1719 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1720         enddo
1721         do k=1,3
1722           dc_norm(k,i)=erij(k)
1723         enddo
1724 cd        do k=1,3
1725 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1726 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1727 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1728 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1729 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1730 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1731 cd          write (iout,'(a)')
1732 cd        enddo
1733       enddo
1734       return
1735       end
1736 C--------------------------------------------------------------------------
1737       subroutine set_matrices
1738       implicit real*8 (a-h,o-z)
1739       include 'DIMENSIONS'
1740       include 'DIMENSIONS.ZSCOPT'
1741       include 'COMMON.IOUNITS'
1742       include 'COMMON.GEO'
1743       include 'COMMON.VAR'
1744       include 'COMMON.LOCAL'
1745       include 'COMMON.CHAIN'
1746       include 'COMMON.DERIV'
1747       include 'COMMON.INTERACT'
1748       include 'COMMON.CONTACTS'
1749       include 'COMMON.TORSION'
1750       include 'COMMON.VECTORS'
1751       include 'COMMON.FFIELD'
1752       double precision auxvec(2),auxmat(2,2)
1753 C
1754 C Compute the virtual-bond-torsional-angle dependent quantities needed
1755 C to calculate the el-loc multibody terms of various order.
1756 C
1757       do i=3,nres+1
1758         if (i .lt. nres+1) then
1759           sin1=dsin(phi(i))
1760           cos1=dcos(phi(i))
1761           sintab(i-2)=sin1
1762           costab(i-2)=cos1
1763           obrot(1,i-2)=cos1
1764           obrot(2,i-2)=sin1
1765           sin2=dsin(2*phi(i))
1766           cos2=dcos(2*phi(i))
1767           sintab2(i-2)=sin2
1768           costab2(i-2)=cos2
1769           obrot2(1,i-2)=cos2
1770           obrot2(2,i-2)=sin2
1771           Ug(1,1,i-2)=-cos1
1772           Ug(1,2,i-2)=-sin1
1773           Ug(2,1,i-2)=-sin1
1774           Ug(2,2,i-2)= cos1
1775           Ug2(1,1,i-2)=-cos2
1776           Ug2(1,2,i-2)=-sin2
1777           Ug2(2,1,i-2)=-sin2
1778           Ug2(2,2,i-2)= cos2
1779         else
1780           costab(i-2)=1.0d0
1781           sintab(i-2)=0.0d0
1782           obrot(1,i-2)=1.0d0
1783           obrot(2,i-2)=0.0d0
1784           obrot2(1,i-2)=0.0d0
1785           obrot2(2,i-2)=0.0d0
1786           Ug(1,1,i-2)=1.0d0
1787           Ug(1,2,i-2)=0.0d0
1788           Ug(2,1,i-2)=0.0d0
1789           Ug(2,2,i-2)=1.0d0
1790           Ug2(1,1,i-2)=0.0d0
1791           Ug2(1,2,i-2)=0.0d0
1792           Ug2(2,1,i-2)=0.0d0
1793           Ug2(2,2,i-2)=0.0d0
1794         endif
1795         if (i .gt. 3 .and. i .lt. nres+1) then
1796           obrot_der(1,i-2)=-sin1
1797           obrot_der(2,i-2)= cos1
1798           Ugder(1,1,i-2)= sin1
1799           Ugder(1,2,i-2)=-cos1
1800           Ugder(2,1,i-2)=-cos1
1801           Ugder(2,2,i-2)=-sin1
1802           dwacos2=cos2+cos2
1803           dwasin2=sin2+sin2
1804           obrot2_der(1,i-2)=-dwasin2
1805           obrot2_der(2,i-2)= dwacos2
1806           Ug2der(1,1,i-2)= dwasin2
1807           Ug2der(1,2,i-2)=-dwacos2
1808           Ug2der(2,1,i-2)=-dwacos2
1809           Ug2der(2,2,i-2)=-dwasin2
1810         else
1811           obrot_der(1,i-2)=0.0d0
1812           obrot_der(2,i-2)=0.0d0
1813           Ugder(1,1,i-2)=0.0d0
1814           Ugder(1,2,i-2)=0.0d0
1815           Ugder(2,1,i-2)=0.0d0
1816           Ugder(2,2,i-2)=0.0d0
1817           obrot2_der(1,i-2)=0.0d0
1818           obrot2_der(2,i-2)=0.0d0
1819           Ug2der(1,1,i-2)=0.0d0
1820           Ug2der(1,2,i-2)=0.0d0
1821           Ug2der(2,1,i-2)=0.0d0
1822           Ug2der(2,2,i-2)=0.0d0
1823         endif
1824         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1825           if (itype(i-2).le.ntyp) then
1826             iti = itortyp(itype(i-2))
1827           else
1828             iti=ntortyp+1
1829           endif
1830         else
1831           iti=ntortyp+1
1832         endif
1833         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1834           if (itype(i-1).le.ntyp) then
1835             iti1 = itortyp(itype(i-1))
1836           else
1837             iti1=ntortyp+1
1838           endif
1839         else
1840           iti1=ntortyp+1
1841         endif
1842 cd        write (iout,*) '*******i',i,' iti1',iti
1843 cd        write (iout,*) 'b1',b1(:,iti)
1844 cd        write (iout,*) 'b2',b2(:,iti)
1845 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1846 c        print *,"itilde1 i iti iti1",i,iti,iti1
1847         if (i .gt. iatel_s+2) then
1848           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1849           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1850           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1851           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1852           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1853           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1854           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1855         else
1856           do k=1,2
1857             Ub2(k,i-2)=0.0d0
1858             Ctobr(k,i-2)=0.0d0
1859             Dtobr2(k,i-2)=0.0d0
1860             do l=1,2
1861               EUg(l,k,i-2)=0.0d0
1862               CUg(l,k,i-2)=0.0d0
1863               DUg(l,k,i-2)=0.0d0
1864               DtUg2(l,k,i-2)=0.0d0
1865             enddo
1866           enddo
1867         endif
1868 c        print *,"itilde2 i iti iti1",i,iti,iti1
1869         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1870         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1871         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1872         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1873         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1874         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1875         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1876 c        print *,"itilde3 i iti iti1",i,iti,iti1
1877         do k=1,2
1878           muder(k,i-2)=Ub2der(k,i-2)
1879         enddo
1880         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1881           if (itype(i-1).le.ntyp) then
1882             iti1 = itortyp(itype(i-1))
1883           else
1884             iti1=ntortyp+1
1885           endif
1886         else
1887           iti1=ntortyp+1
1888         endif
1889         do k=1,2
1890           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1891         enddo
1892 C Vectors and matrices dependent on a single virtual-bond dihedral.
1893         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1894         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1895         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1896         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1897         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1898         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1899         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1900         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1901         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1902 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1903 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1904       enddo
1905 C Matrices dependent on two consecutive virtual-bond dihedrals.
1906 C The order of matrices is from left to right.
1907       do i=2,nres-1
1908         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1909         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1910         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1911         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1912         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1913         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1914         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1915         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1916       enddo
1917 cd      do i=1,nres
1918 cd        iti = itortyp(itype(i))
1919 cd        write (iout,*) i
1920 cd        do j=1,2
1921 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1922 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1923 cd        enddo
1924 cd      enddo
1925       return
1926       end
1927 C--------------------------------------------------------------------------
1928       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1929 C
1930 C This subroutine calculates the average interaction energy and its gradient
1931 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1932 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1933 C The potential depends both on the distance of peptide-group centers and on
1934 C the orientation of the CA-CA virtual bonds.
1935 C
1936       implicit real*8 (a-h,o-z)
1937       include 'DIMENSIONS'
1938       include 'DIMENSIONS.ZSCOPT'
1939       include 'DIMENSIONS.FREE'
1940       include 'COMMON.CONTROL'
1941       include 'COMMON.IOUNITS'
1942       include 'COMMON.GEO'
1943       include 'COMMON.VAR'
1944       include 'COMMON.LOCAL'
1945       include 'COMMON.CHAIN'
1946       include 'COMMON.DERIV'
1947       include 'COMMON.INTERACT'
1948       include 'COMMON.CONTACTS'
1949       include 'COMMON.TORSION'
1950       include 'COMMON.VECTORS'
1951       include 'COMMON.FFIELD'
1952       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1953      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1954       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1955      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1956       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1957 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1958       double precision scal_el /0.5d0/
1959 C 12/13/98
1960 C 13-go grudnia roku pamietnego...
1961       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1962      &                   0.0d0,1.0d0,0.0d0,
1963      &                   0.0d0,0.0d0,1.0d0/
1964 cd      write(iout,*) 'In EELEC'
1965 cd      do i=1,nloctyp
1966 cd        write(iout,*) 'Type',i
1967 cd        write(iout,*) 'B1',B1(:,i)
1968 cd        write(iout,*) 'B2',B2(:,i)
1969 cd        write(iout,*) 'CC',CC(:,:,i)
1970 cd        write(iout,*) 'DD',DD(:,:,i)
1971 cd        write(iout,*) 'EE',EE(:,:,i)
1972 cd      enddo
1973 cd      call check_vecgrad
1974 cd      stop
1975       if (icheckgrad.eq.1) then
1976         do i=1,nres-1
1977           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1978           do k=1,3
1979             dc_norm(k,i)=dc(k,i)*fac
1980           enddo
1981 c          write (iout,*) 'i',i,' fac',fac
1982         enddo
1983       endif
1984       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1985      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1986      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1987 cd      if (wel_loc.gt.0.0d0) then
1988         if (icheckgrad.eq.1) then
1989         call vec_and_deriv_test
1990         else
1991         call vec_and_deriv
1992         endif
1993         call set_matrices
1994       endif
1995 cd      do i=1,nres-1
1996 cd        write (iout,*) 'i=',i
1997 cd        do k=1,3
1998 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1999 cd        enddo
2000 cd        do k=1,3
2001 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2002 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2003 cd        enddo
2004 cd      enddo
2005       num_conti_hb=0
2006       ees=0.0D0
2007       evdw1=0.0D0
2008       eel_loc=0.0d0
2009       eello_turn3=0.0d0
2010       eello_turn4=0.0d0
2011       ind=0
2012       do i=1,nres
2013         num_cont_hb(i)=0
2014       enddo
2015 cd      print '(a)','Enter EELEC'
2016 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2017       do i=1,nres
2018         gel_loc_loc(i)=0.0d0
2019         gcorr_loc(i)=0.0d0
2020       enddo
2021       do i=iatel_s,iatel_e
2022            if (i.le.1) cycle
2023            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2024      &  .or. ((i+2).gt.nres)
2025      &  .or. ((i-1).le.0)
2026      &  .or. itype(i+2).eq.ntyp1
2027      &  .or. itype(i-1).eq.ntyp1
2028      &) cycle
2029 C         endif
2030         if (itel(i).eq.0) goto 1215
2031         dxi=dc(1,i)
2032         dyi=dc(2,i)
2033         dzi=dc(3,i)
2034         dx_normi=dc_norm(1,i)
2035         dy_normi=dc_norm(2,i)
2036         dz_normi=dc_norm(3,i)
2037         xmedi=c(1,i)+0.5d0*dxi
2038         ymedi=c(2,i)+0.5d0*dyi
2039         zmedi=c(3,i)+0.5d0*dzi
2040           xmedi=mod(xmedi,boxxsize)
2041           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2042           ymedi=mod(ymedi,boxysize)
2043           if (ymedi.lt.0) ymedi=ymedi+boxysize
2044           zmedi=mod(zmedi,boxzsize)
2045           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2046         num_conti=0
2047 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2048         do j=ielstart(i),ielend(i)
2049           if (j.le.1) cycle
2050           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2051      & .or.((j+2).gt.nres)
2052      & .or.((j-1).le.0)
2053      & .or.itype(j+2).eq.ntyp1
2054      & .or.itype(j-1).eq.ntyp1
2055      &) cycle
2056           if (itel(j).eq.0) goto 1216
2057           ind=ind+1
2058           iteli=itel(i)
2059           itelj=itel(j)
2060           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2061           aaa=app(iteli,itelj)
2062           bbb=bpp(iteli,itelj)
2063 C Diagnostics only!!!
2064 c         aaa=0.0D0
2065 c         bbb=0.0D0
2066 c         ael6i=0.0D0
2067 c         ael3i=0.0D0
2068 C End diagnostics
2069           ael6i=ael6(iteli,itelj)
2070           ael3i=ael3(iteli,itelj)
2071           dxj=dc(1,j)
2072           dyj=dc(2,j)
2073           dzj=dc(3,j)
2074           dx_normj=dc_norm(1,j)
2075           dy_normj=dc_norm(2,j)
2076           dz_normj=dc_norm(3,j)
2077           xj=c(1,j)+0.5D0*dxj
2078           yj=c(2,j)+0.5D0*dyj
2079           zj=c(3,j)+0.5D0*dzj
2080          xj=mod(xj,boxxsize)
2081           if (xj.lt.0) xj=xj+boxxsize
2082           yj=mod(yj,boxysize)
2083           if (yj.lt.0) yj=yj+boxysize
2084           zj=mod(zj,boxzsize)
2085           if (zj.lt.0) zj=zj+boxzsize
2086       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2087       xj_safe=xj
2088       yj_safe=yj
2089       zj_safe=zj
2090       isubchap=0
2091       do xshift=-1,1
2092       do yshift=-1,1
2093       do zshift=-1,1
2094           xj=xj_safe+xshift*boxxsize
2095           yj=yj_safe+yshift*boxysize
2096           zj=zj_safe+zshift*boxzsize
2097           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2098           if(dist_temp.lt.dist_init) then
2099             dist_init=dist_temp
2100             xj_temp=xj
2101             yj_temp=yj
2102             zj_temp=zj
2103             isubchap=1
2104           endif
2105        enddo
2106        enddo
2107        enddo
2108        if (isubchap.eq.1) then
2109           xj=xj_temp-xmedi
2110           yj=yj_temp-ymedi
2111           zj=zj_temp-zmedi
2112        else
2113           xj=xj_safe-xmedi
2114           yj=yj_safe-ymedi
2115           zj=zj_safe-zmedi
2116        endif
2117           rij=xj*xj+yj*yj+zj*zj
2118             sss=sscale(sqrt(rij))
2119             sssgrad=sscagrad(sqrt(rij))
2120           rrmij=1.0D0/rij
2121           rij=dsqrt(rij)
2122           rmij=1.0D0/rij
2123           r3ij=rrmij*rmij
2124           r6ij=r3ij*r3ij
2125           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2126           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2127           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2128           fac=cosa-3.0D0*cosb*cosg
2129           ev1=aaa*r6ij*r6ij
2130 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2131           if (j.eq.i+2) ev1=scal_el*ev1
2132           ev2=bbb*r6ij
2133           fac3=ael6i*r6ij
2134           fac4=ael3i*r3ij
2135           evdwij=ev1+ev2
2136           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2137           el2=fac4*fac
2138           eesij=el1+el2
2139 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2140 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2141           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2142           ees=ees+eesij
2143           evdw1=evdw1+evdwij*sss
2144 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2145 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2146 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2147 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2148 C
2149 C Calculate contributions to the Cartesian gradient.
2150 C
2151 #ifdef SPLITELE
2152           facvdw=-6*rrmij*(ev1+evdwij)*sss
2153           facel=-3*rrmij*(el1+eesij)
2154           fac1=fac
2155           erij(1)=xj*rmij
2156           erij(2)=yj*rmij
2157           erij(3)=zj*rmij
2158           if (calc_grad) then
2159 *
2160 * Radial derivatives. First process both termini of the fragment (i,j)
2161 *
2162           ggg(1)=facel*xj
2163           ggg(2)=facel*yj
2164           ggg(3)=facel*zj
2165           do k=1,3
2166             ghalf=0.5D0*ggg(k)
2167             gelc(k,i)=gelc(k,i)+ghalf
2168             gelc(k,j)=gelc(k,j)+ghalf
2169           enddo
2170 *
2171 * Loop over residues i+1 thru j-1.
2172 *
2173           do k=i+1,j-1
2174             do l=1,3
2175               gelc(l,k)=gelc(l,k)+ggg(l)
2176             enddo
2177           enddo
2178           ggg(1)=facvdw*xj
2179           ggg(2)=facvdw*yj
2180           ggg(3)=facvdw*zj
2181           do k=1,3
2182             ghalf=0.5D0*ggg(k)
2183             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2184             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2185           enddo
2186 *
2187 * Loop over residues i+1 thru j-1.
2188 *
2189           do k=i+1,j-1
2190             do l=1,3
2191               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2192             enddo
2193           enddo
2194 #else
2195           facvdw=ev1+evdwij
2196           facel=el1+eesij
2197           fac1=fac
2198           fac=-3*rrmij*(facvdw+facvdw+facel)
2199           erij(1)=xj*rmij
2200           erij(2)=yj*rmij
2201           erij(3)=zj*rmij
2202           if (calc_grad) then
2203 *
2204 * Radial derivatives. First process both termini of the fragment (i,j)
2205 *
2206           ggg(1)=fac*xj
2207           ggg(2)=fac*yj
2208           ggg(3)=fac*zj
2209           do k=1,3
2210             ghalf=0.5D0*ggg(k)
2211             gelc(k,i)=gelc(k,i)+ghalf
2212             gelc(k,j)=gelc(k,j)+ghalf
2213           enddo
2214 *
2215 * Loop over residues i+1 thru j-1.
2216 *
2217           do k=i+1,j-1
2218             do l=1,3
2219               gelc(l,k)=gelc(l,k)+ggg(l)
2220             enddo
2221           enddo
2222 #endif
2223 *
2224 * Angular part
2225 *
2226           ecosa=2.0D0*fac3*fac1+fac4
2227           fac4=-3.0D0*fac4
2228           fac3=-6.0D0*fac3
2229           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2230           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2231           do k=1,3
2232             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2233             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2234           enddo
2235 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2236 cd   &          (dcosg(k),k=1,3)
2237           do k=1,3
2238             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2239           enddo
2240           do k=1,3
2241             ghalf=0.5D0*ggg(k)
2242             gelc(k,i)=gelc(k,i)+ghalf
2243      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2244      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2245             gelc(k,j)=gelc(k,j)+ghalf
2246      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2247      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2248           enddo
2249           do k=i+1,j-1
2250             do l=1,3
2251               gelc(l,k)=gelc(l,k)+ggg(l)
2252             enddo
2253           enddo
2254           endif
2255
2256           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2257      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2258      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2259 C
2260 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2261 C   energy of a peptide unit is assumed in the form of a second-order
2262 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2263 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2264 C   are computed for EVERY pair of non-contiguous peptide groups.
2265 C
2266           if (j.lt.nres-1) then
2267             j1=j+1
2268             j2=j-1
2269           else
2270             j1=j-1
2271             j2=j-2
2272           endif
2273           kkk=0
2274           do k=1,2
2275             do l=1,2
2276               kkk=kkk+1
2277               muij(kkk)=mu(k,i)*mu(l,j)
2278             enddo
2279           enddo
2280 cd         write (iout,*) 'EELEC: i',i,' j',j
2281 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2282 cd          write(iout,*) 'muij',muij
2283           ury=scalar(uy(1,i),erij)
2284           urz=scalar(uz(1,i),erij)
2285           vry=scalar(uy(1,j),erij)
2286           vrz=scalar(uz(1,j),erij)
2287           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2288           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2289           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2290           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2291 C For diagnostics only
2292 cd          a22=1.0d0
2293 cd          a23=1.0d0
2294 cd          a32=1.0d0
2295 cd          a33=1.0d0
2296           fac=dsqrt(-ael6i)*r3ij
2297 cd          write (2,*) 'fac=',fac
2298 C For diagnostics only
2299 cd          fac=1.0d0
2300           a22=a22*fac
2301           a23=a23*fac
2302           a32=a32*fac
2303           a33=a33*fac
2304 cd          write (iout,'(4i5,4f10.5)')
2305 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2306 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2307 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2308 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2309 cd          write (iout,'(4f10.5)')
2310 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2311 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2312 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2313 cd           write (iout,'(2i3,9f10.5/)') i,j,
2314 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2315           if (calc_grad) then
2316 C Derivatives of the elements of A in virtual-bond vectors
2317           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2318 cd          do k=1,3
2319 cd            do l=1,3
2320 cd              erder(k,l)=0.0d0
2321 cd            enddo
2322 cd          enddo
2323           do k=1,3
2324             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2325             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2326             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2327             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2328             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2329             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2330             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2331             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2332             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2333             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2334             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2335             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2336           enddo
2337 cd          do k=1,3
2338 cd            do l=1,3
2339 cd              uryg(k,l)=0.0d0
2340 cd              urzg(k,l)=0.0d0
2341 cd              vryg(k,l)=0.0d0
2342 cd              vrzg(k,l)=0.0d0
2343 cd            enddo
2344 cd          enddo
2345 C Compute radial contributions to the gradient
2346           facr=-3.0d0*rrmij
2347           a22der=a22*facr
2348           a23der=a23*facr
2349           a32der=a32*facr
2350           a33der=a33*facr
2351 cd          a22der=0.0d0
2352 cd          a23der=0.0d0
2353 cd          a32der=0.0d0
2354 cd          a33der=0.0d0
2355           agg(1,1)=a22der*xj
2356           agg(2,1)=a22der*yj
2357           agg(3,1)=a22der*zj
2358           agg(1,2)=a23der*xj
2359           agg(2,2)=a23der*yj
2360           agg(3,2)=a23der*zj
2361           agg(1,3)=a32der*xj
2362           agg(2,3)=a32der*yj
2363           agg(3,3)=a32der*zj
2364           agg(1,4)=a33der*xj
2365           agg(2,4)=a33der*yj
2366           agg(3,4)=a33der*zj
2367 C Add the contributions coming from er
2368           fac3=-3.0d0*fac
2369           do k=1,3
2370             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2371             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2372             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2373             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2374           enddo
2375           do k=1,3
2376 C Derivatives in DC(i)
2377             ghalf1=0.5d0*agg(k,1)
2378             ghalf2=0.5d0*agg(k,2)
2379             ghalf3=0.5d0*agg(k,3)
2380             ghalf4=0.5d0*agg(k,4)
2381             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2382      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2383             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2384      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2385             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2386      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2387             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2388      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2389 C Derivatives in DC(i+1)
2390             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2391      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2392             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2393      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2394             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2395      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2396             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2397      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2398 C Derivatives in DC(j)
2399             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2400      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2401             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2402      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2403             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2404      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2405             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2406      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2407 C Derivatives in DC(j+1) or DC(nres-1)
2408             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2409      &      -3.0d0*vryg(k,3)*ury)
2410             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2411      &      -3.0d0*vrzg(k,3)*ury)
2412             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2413      &      -3.0d0*vryg(k,3)*urz)
2414             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2415      &      -3.0d0*vrzg(k,3)*urz)
2416 cd            aggi(k,1)=ghalf1
2417 cd            aggi(k,2)=ghalf2
2418 cd            aggi(k,3)=ghalf3
2419 cd            aggi(k,4)=ghalf4
2420 C Derivatives in DC(i+1)
2421 cd            aggi1(k,1)=agg(k,1)
2422 cd            aggi1(k,2)=agg(k,2)
2423 cd            aggi1(k,3)=agg(k,3)
2424 cd            aggi1(k,4)=agg(k,4)
2425 C Derivatives in DC(j)
2426 cd            aggj(k,1)=ghalf1
2427 cd            aggj(k,2)=ghalf2
2428 cd            aggj(k,3)=ghalf3
2429 cd            aggj(k,4)=ghalf4
2430 C Derivatives in DC(j+1)
2431 cd            aggj1(k,1)=0.0d0
2432 cd            aggj1(k,2)=0.0d0
2433 cd            aggj1(k,3)=0.0d0
2434 cd            aggj1(k,4)=0.0d0
2435             if (j.eq.nres-1 .and. i.lt.j-2) then
2436               do l=1,4
2437                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2438 cd                aggj1(k,l)=agg(k,l)
2439               enddo
2440             endif
2441           enddo
2442           endif
2443 c          goto 11111
2444 C Check the loc-el terms by numerical integration
2445           acipa(1,1)=a22
2446           acipa(1,2)=a23
2447           acipa(2,1)=a32
2448           acipa(2,2)=a33
2449           a22=-a22
2450           a23=-a23
2451           do l=1,2
2452             do k=1,3
2453               agg(k,l)=-agg(k,l)
2454               aggi(k,l)=-aggi(k,l)
2455               aggi1(k,l)=-aggi1(k,l)
2456               aggj(k,l)=-aggj(k,l)
2457               aggj1(k,l)=-aggj1(k,l)
2458             enddo
2459           enddo
2460           if (j.lt.nres-1) then
2461             a22=-a22
2462             a32=-a32
2463             do l=1,3,2
2464               do k=1,3
2465                 agg(k,l)=-agg(k,l)
2466                 aggi(k,l)=-aggi(k,l)
2467                 aggi1(k,l)=-aggi1(k,l)
2468                 aggj(k,l)=-aggj(k,l)
2469                 aggj1(k,l)=-aggj1(k,l)
2470               enddo
2471             enddo
2472           else
2473             a22=-a22
2474             a23=-a23
2475             a32=-a32
2476             a33=-a33
2477             do l=1,4
2478               do k=1,3
2479                 agg(k,l)=-agg(k,l)
2480                 aggi(k,l)=-aggi(k,l)
2481                 aggi1(k,l)=-aggi1(k,l)
2482                 aggj(k,l)=-aggj(k,l)
2483                 aggj1(k,l)=-aggj1(k,l)
2484               enddo
2485             enddo
2486           endif
2487           ENDIF ! WCORR
2488 11111     continue
2489           IF (wel_loc.gt.0.0d0) THEN
2490 C Contribution to the local-electrostatic energy coming from the i-j pair
2491           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2492      &     +a33*muij(4)
2493 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2494 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2495           eel_loc=eel_loc+eel_loc_ij
2496 C Partial derivatives in virtual-bond dihedral angles gamma
2497           if (calc_grad) then
2498           if (i.gt.1)
2499      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2500      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2501      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2502           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2503      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2504      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2505 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2506 cd          write(iout,*) 'agg  ',agg
2507 cd          write(iout,*) 'aggi ',aggi
2508 cd          write(iout,*) 'aggi1',aggi1
2509 cd          write(iout,*) 'aggj ',aggj
2510 cd          write(iout,*) 'aggj1',aggj1
2511
2512 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2513           do l=1,3
2514             ggg(l)=agg(l,1)*muij(1)+
2515      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2516           enddo
2517           do k=i+2,j2
2518             do l=1,3
2519               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2520             enddo
2521           enddo
2522 C Remaining derivatives of eello
2523           do l=1,3
2524             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2525      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2526             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2527      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2528             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2529      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2530             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2531      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2532           enddo
2533           endif
2534           ENDIF
2535           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2536 C Contributions from turns
2537             a_temp(1,1)=a22
2538             a_temp(1,2)=a23
2539             a_temp(2,1)=a32
2540             a_temp(2,2)=a33
2541             call eturn34(i,j,eello_turn3,eello_turn4)
2542           endif
2543 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2544           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2545 C
2546 C Calculate the contact function. The ith column of the array JCONT will
2547 C contain the numbers of atoms that make contacts with the atom I (of numbers
2548 C greater than I). The arrays FACONT and GACONT will contain the values of
2549 C the contact function and its derivative.
2550 c           r0ij=1.02D0*rpp(iteli,itelj)
2551 c           r0ij=1.11D0*rpp(iteli,itelj)
2552             r0ij=2.20D0*rpp(iteli,itelj)
2553 c           r0ij=1.55D0*rpp(iteli,itelj)
2554             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2555             if (fcont.gt.0.0D0) then
2556               num_conti=num_conti+1
2557               if (num_conti.gt.maxconts) then
2558                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2559      &                         ' will skip next contacts for this conf.'
2560               else
2561                 jcont_hb(num_conti,i)=j
2562                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2563      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2564 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2565 C  terms.
2566                 d_cont(num_conti,i)=rij
2567 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2568 C     --- Electrostatic-interaction matrix ---
2569                 a_chuj(1,1,num_conti,i)=a22
2570                 a_chuj(1,2,num_conti,i)=a23
2571                 a_chuj(2,1,num_conti,i)=a32
2572                 a_chuj(2,2,num_conti,i)=a33
2573 C     --- Gradient of rij
2574                 do kkk=1,3
2575                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2576                 enddo
2577 c             if (i.eq.1) then
2578 c                a_chuj(1,1,num_conti,i)=-0.61d0
2579 c                a_chuj(1,2,num_conti,i)= 0.4d0
2580 c                a_chuj(2,1,num_conti,i)= 0.65d0
2581 c                a_chuj(2,2,num_conti,i)= 0.50d0
2582 c             else if (i.eq.2) then
2583 c                a_chuj(1,1,num_conti,i)= 0.0d0
2584 c                a_chuj(1,2,num_conti,i)= 0.0d0
2585 c                a_chuj(2,1,num_conti,i)= 0.0d0
2586 c                a_chuj(2,2,num_conti,i)= 0.0d0
2587 c             endif
2588 C     --- and its gradients
2589 cd                write (iout,*) 'i',i,' j',j
2590 cd                do kkk=1,3
2591 cd                write (iout,*) 'iii 1 kkk',kkk
2592 cd                write (iout,*) agg(kkk,:)
2593 cd                enddo
2594 cd                do kkk=1,3
2595 cd                write (iout,*) 'iii 2 kkk',kkk
2596 cd                write (iout,*) aggi(kkk,:)
2597 cd                enddo
2598 cd                do kkk=1,3
2599 cd                write (iout,*) 'iii 3 kkk',kkk
2600 cd                write (iout,*) aggi1(kkk,:)
2601 cd                enddo
2602 cd                do kkk=1,3
2603 cd                write (iout,*) 'iii 4 kkk',kkk
2604 cd                write (iout,*) aggj(kkk,:)
2605 cd                enddo
2606 cd                do kkk=1,3
2607 cd                write (iout,*) 'iii 5 kkk',kkk
2608 cd                write (iout,*) aggj1(kkk,:)
2609 cd                enddo
2610                 kkll=0
2611                 do k=1,2
2612                   do l=1,2
2613                     kkll=kkll+1
2614                     do m=1,3
2615                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2616                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2617                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2618                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2619                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2620 c                      do mm=1,5
2621 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2622 c                      enddo
2623                     enddo
2624                   enddo
2625                 enddo
2626                 ENDIF
2627                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2628 C Calculate contact energies
2629                 cosa4=4.0D0*cosa
2630                 wij=cosa-3.0D0*cosb*cosg
2631                 cosbg1=cosb+cosg
2632                 cosbg2=cosb-cosg
2633 c               fac3=dsqrt(-ael6i)/r0ij**3
2634                 fac3=dsqrt(-ael6i)*r3ij
2635                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2636                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2637 c               ees0mij=0.0D0
2638                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2639                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2640 C Diagnostics. Comment out or remove after debugging!
2641 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2642 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2643 c               ees0m(num_conti,i)=0.0D0
2644 C End diagnostics.
2645 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2646 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2647                 facont_hb(num_conti,i)=fcont
2648                 if (calc_grad) then
2649 C Angular derivatives of the contact function
2650                 ees0pij1=fac3/ees0pij
2651                 ees0mij1=fac3/ees0mij
2652                 fac3p=-3.0D0*fac3*rrmij
2653                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2654                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2655 c               ees0mij1=0.0D0
2656                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2657                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2658                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2659                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2660                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2661                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2662                 ecosap=ecosa1+ecosa2
2663                 ecosbp=ecosb1+ecosb2
2664                 ecosgp=ecosg1+ecosg2
2665                 ecosam=ecosa1-ecosa2
2666                 ecosbm=ecosb1-ecosb2
2667                 ecosgm=ecosg1-ecosg2
2668 C Diagnostics
2669 c               ecosap=ecosa1
2670 c               ecosbp=ecosb1
2671 c               ecosgp=ecosg1
2672 c               ecosam=0.0D0
2673 c               ecosbm=0.0D0
2674 c               ecosgm=0.0D0
2675 C End diagnostics
2676                 fprimcont=fprimcont/rij
2677 cd              facont_hb(num_conti,i)=1.0D0
2678 C Following line is for diagnostics.
2679 cd              fprimcont=0.0D0
2680                 do k=1,3
2681                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2682                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2683                 enddo
2684                 do k=1,3
2685                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2686                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2687                 enddo
2688                 gggp(1)=gggp(1)+ees0pijp*xj
2689                 gggp(2)=gggp(2)+ees0pijp*yj
2690                 gggp(3)=gggp(3)+ees0pijp*zj
2691                 gggm(1)=gggm(1)+ees0mijp*xj
2692                 gggm(2)=gggm(2)+ees0mijp*yj
2693                 gggm(3)=gggm(3)+ees0mijp*zj
2694 C Derivatives due to the contact function
2695                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2696                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2697                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2698                 do k=1,3
2699                   ghalfp=0.5D0*gggp(k)
2700                   ghalfm=0.5D0*gggm(k)
2701                   gacontp_hb1(k,num_conti,i)=ghalfp
2702      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2703      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2704                   gacontp_hb2(k,num_conti,i)=ghalfp
2705      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2706      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2707                   gacontp_hb3(k,num_conti,i)=gggp(k)
2708                   gacontm_hb1(k,num_conti,i)=ghalfm
2709      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2710      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2711                   gacontm_hb2(k,num_conti,i)=ghalfm
2712      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2713      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2714                   gacontm_hb3(k,num_conti,i)=gggm(k)
2715                 enddo
2716                 endif
2717 C Diagnostics. Comment out or remove after debugging!
2718 cdiag           do k=1,3
2719 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2720 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2721 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2722 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2723 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2724 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2725 cdiag           enddo
2726               ENDIF ! wcorr
2727               endif  ! num_conti.le.maxconts
2728             endif  ! fcont.gt.0
2729           endif    ! j.gt.i+1
2730  1216     continue
2731         enddo ! j
2732         num_cont_hb(i)=num_conti
2733  1215   continue
2734       enddo   ! i
2735 cd      do i=1,nres
2736 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2737 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2738 cd      enddo
2739 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2740 ccc      eel_loc=eel_loc+eello_turn3
2741       return
2742       end
2743 C-----------------------------------------------------------------------------
2744       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2745 C Third- and fourth-order contributions from turns
2746       implicit real*8 (a-h,o-z)
2747       include 'DIMENSIONS'
2748       include 'DIMENSIONS.ZSCOPT'
2749       include 'COMMON.IOUNITS'
2750       include 'COMMON.GEO'
2751       include 'COMMON.VAR'
2752       include 'COMMON.LOCAL'
2753       include 'COMMON.CHAIN'
2754       include 'COMMON.DERIV'
2755       include 'COMMON.INTERACT'
2756       include 'COMMON.CONTACTS'
2757       include 'COMMON.TORSION'
2758       include 'COMMON.VECTORS'
2759       include 'COMMON.FFIELD'
2760       dimension ggg(3)
2761       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2762      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2763      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2764       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2765      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2766       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2767       if (j.eq.i+2) then
2768       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2769 C changes suggested by Ana to avoid out of bounds
2770 C     & .or.((i+5).gt.nres)
2771 C     & .or.((i-1).le.0)
2772 C end of changes suggested by Ana
2773      &    .or. itype(i+2).eq.ntyp1
2774      &    .or. itype(i+3).eq.ntyp1
2775 C     &    .or. itype(i+5).eq.ntyp1
2776 C     &    .or. itype(i).eq.ntyp1
2777 C     &    .or. itype(i-1).eq.ntyp1
2778      &    ) goto 179
2779
2780 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2781 C
2782 C               Third-order contributions
2783 C
2784 C                 (i+2)o----(i+3)
2785 C                      | |
2786 C                      | |
2787 C                 (i+1)o----i
2788 C
2789 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2790 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2791         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2792         call transpose2(auxmat(1,1),auxmat1(1,1))
2793         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2794         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2795 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2796 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2797 cd     &    ' eello_turn3_num',4*eello_turn3_num
2798         if (calc_grad) then
2799 C Derivatives in gamma(i)
2800         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2801         call transpose2(auxmat2(1,1),pizda(1,1))
2802         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2803         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2804 C Derivatives in gamma(i+1)
2805         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2806         call transpose2(auxmat2(1,1),pizda(1,1))
2807         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2808         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2809      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2810 C Cartesian derivatives
2811         do l=1,3
2812           a_temp(1,1)=aggi(l,1)
2813           a_temp(1,2)=aggi(l,2)
2814           a_temp(2,1)=aggi(l,3)
2815           a_temp(2,2)=aggi(l,4)
2816           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2817           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2818      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2819           a_temp(1,1)=aggi1(l,1)
2820           a_temp(1,2)=aggi1(l,2)
2821           a_temp(2,1)=aggi1(l,3)
2822           a_temp(2,2)=aggi1(l,4)
2823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2824           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2825      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2826           a_temp(1,1)=aggj(l,1)
2827           a_temp(1,2)=aggj(l,2)
2828           a_temp(2,1)=aggj(l,3)
2829           a_temp(2,2)=aggj(l,4)
2830           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2831           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2832      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2833           a_temp(1,1)=aggj1(l,1)
2834           a_temp(1,2)=aggj1(l,2)
2835           a_temp(2,1)=aggj1(l,3)
2836           a_temp(2,2)=aggj1(l,4)
2837           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2838           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2839      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2840         enddo
2841         endif
2842   179 continue
2843       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2844       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2845 C changes suggested by Ana to avoid out of bounds
2846 C     & .or.((i+5).gt.nres)
2847 C     & .or.((i-1).le.0)
2848 C end of changes suggested by Ana
2849      &    .or. itype(i+3).eq.ntyp1
2850      &    .or. itype(i+4).eq.ntyp1
2851 C     &    .or. itype(i+5).eq.ntyp1
2852      &    .or. itype(i).eq.ntyp1
2853 C     &    .or. itype(i-1).eq.ntyp1
2854      &    ) goto 178
2855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2856 C
2857 C               Fourth-order contributions
2858 C
2859 C                 (i+3)o----(i+4)
2860 C                     /  |
2861 C               (i+2)o   |
2862 C                     \  |
2863 C                 (i+1)o----i
2864 C
2865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2866 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2867         iti1=itortyp(itype(i+1))
2868         iti2=itortyp(itype(i+2))
2869         iti3=itortyp(itype(i+3))
2870         call transpose2(EUg(1,1,i+1),e1t(1,1))
2871         call transpose2(Eug(1,1,i+2),e2t(1,1))
2872         call transpose2(Eug(1,1,i+3),e3t(1,1))
2873         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2874         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2875         s1=scalar2(b1(1,iti2),auxvec(1))
2876         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2877         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2878         s2=scalar2(b1(1,iti1),auxvec(1))
2879         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2880         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2881         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2882         eello_turn4=eello_turn4-(s1+s2+s3)
2883 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2884 cd     &    ' eello_turn4_num',8*eello_turn4_num
2885 C Derivatives in gamma(i)
2886         if (calc_grad) then
2887         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2888         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2889         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2890         s1=scalar2(b1(1,iti2),auxvec(1))
2891         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2892         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2893         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2894 C Derivatives in gamma(i+1)
2895         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2896         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2897         s2=scalar2(b1(1,iti1),auxvec(1))
2898         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2899         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2900         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2901         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2902 C Derivatives in gamma(i+2)
2903         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2904         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2905         s1=scalar2(b1(1,iti2),auxvec(1))
2906         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2907         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2908         s2=scalar2(b1(1,iti1),auxvec(1))
2909         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2910         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2911         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2912         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2913 C Cartesian derivatives
2914 C Derivatives of this turn contributions in DC(i+2)
2915         if (j.lt.nres-1) then
2916           do l=1,3
2917             a_temp(1,1)=agg(l,1)
2918             a_temp(1,2)=agg(l,2)
2919             a_temp(2,1)=agg(l,3)
2920             a_temp(2,2)=agg(l,4)
2921             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2922             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2923             s1=scalar2(b1(1,iti2),auxvec(1))
2924             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2925             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2926             s2=scalar2(b1(1,iti1),auxvec(1))
2927             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2928             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2929             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2930             ggg(l)=-(s1+s2+s3)
2931             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2932           enddo
2933         endif
2934 C Remaining derivatives of this turn contribution
2935         do l=1,3
2936           a_temp(1,1)=aggi(l,1)
2937           a_temp(1,2)=aggi(l,2)
2938           a_temp(2,1)=aggi(l,3)
2939           a_temp(2,2)=aggi(l,4)
2940           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2941           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2942           s1=scalar2(b1(1,iti2),auxvec(1))
2943           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2944           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2945           s2=scalar2(b1(1,iti1),auxvec(1))
2946           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2947           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2948           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2949           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2950           a_temp(1,1)=aggi1(l,1)
2951           a_temp(1,2)=aggi1(l,2)
2952           a_temp(2,1)=aggi1(l,3)
2953           a_temp(2,2)=aggi1(l,4)
2954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2956           s1=scalar2(b1(1,iti2),auxvec(1))
2957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2959           s2=scalar2(b1(1,iti1),auxvec(1))
2960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2963           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2964           a_temp(1,1)=aggj(l,1)
2965           a_temp(1,2)=aggj(l,2)
2966           a_temp(2,1)=aggj(l,3)
2967           a_temp(2,2)=aggj(l,4)
2968           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2969           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2970           s1=scalar2(b1(1,iti2),auxvec(1))
2971           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2972           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2973           s2=scalar2(b1(1,iti1),auxvec(1))
2974           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2975           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2976           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2977           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2978           a_temp(1,1)=aggj1(l,1)
2979           a_temp(1,2)=aggj1(l,2)
2980           a_temp(2,1)=aggj1(l,3)
2981           a_temp(2,2)=aggj1(l,4)
2982           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2983           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2984           s1=scalar2(b1(1,iti2),auxvec(1))
2985           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2986           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2987           s2=scalar2(b1(1,iti1),auxvec(1))
2988           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2989           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2990           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2991           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2992         enddo
2993         endif
2994  178  continue
2995       endif
2996       return
2997       end
2998 C-----------------------------------------------------------------------------
2999       subroutine vecpr(u,v,w)
3000       implicit real*8(a-h,o-z)
3001       dimension u(3),v(3),w(3)
3002       w(1)=u(2)*v(3)-u(3)*v(2)
3003       w(2)=-u(1)*v(3)+u(3)*v(1)
3004       w(3)=u(1)*v(2)-u(2)*v(1)
3005       return
3006       end
3007 C-----------------------------------------------------------------------------
3008       subroutine unormderiv(u,ugrad,unorm,ungrad)
3009 C This subroutine computes the derivatives of a normalized vector u, given
3010 C the derivatives computed without normalization conditions, ugrad. Returns
3011 C ungrad.
3012       implicit none
3013       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3014       double precision vec(3)
3015       double precision scalar
3016       integer i,j
3017 c      write (2,*) 'ugrad',ugrad
3018 c      write (2,*) 'u',u
3019       do i=1,3
3020         vec(i)=scalar(ugrad(1,i),u(1))
3021       enddo
3022 c      write (2,*) 'vec',vec
3023       do i=1,3
3024         do j=1,3
3025           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3026         enddo
3027       enddo
3028 c      write (2,*) 'ungrad',ungrad
3029       return
3030       end
3031 C-----------------------------------------------------------------------------
3032       subroutine escp(evdw2,evdw2_14)
3033 C
3034 C This subroutine calculates the excluded-volume interaction energy between
3035 C peptide-group centers and side chains and its gradient in virtual-bond and
3036 C side-chain vectors.
3037 C
3038       implicit real*8 (a-h,o-z)
3039       include 'DIMENSIONS'
3040       include 'DIMENSIONS.ZSCOPT'
3041       include 'COMMON.GEO'
3042       include 'COMMON.VAR'
3043       include 'COMMON.LOCAL'
3044       include 'COMMON.CHAIN'
3045       include 'COMMON.DERIV'
3046       include 'COMMON.INTERACT'
3047       include 'COMMON.FFIELD'
3048       include 'COMMON.IOUNITS'
3049       dimension ggg(3)
3050       evdw2=0.0D0
3051       evdw2_14=0.0d0
3052 cd    print '(a)','Enter ESCP'
3053 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3054 c     &  ' scal14',scal14
3055       do i=iatscp_s,iatscp_e
3056         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3057         iteli=itel(i)
3058 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3059 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3060         if (iteli.eq.0) goto 1225
3061         xi=0.5D0*(c(1,i)+c(1,i+1))
3062         yi=0.5D0*(c(2,i)+c(2,i+1))
3063         zi=0.5D0*(c(3,i)+c(3,i+1))
3064 C Returning the ith atom to box
3065           xi=mod(xi,boxxsize)
3066           if (xi.lt.0) xi=xi+boxxsize
3067           yi=mod(yi,boxysize)
3068           if (yi.lt.0) yi=yi+boxysize
3069           zi=mod(zi,boxzsize)
3070           if (zi.lt.0) zi=zi+boxzsize
3071         do iint=1,nscp_gr(i)
3072
3073         do j=iscpstart(i,iint),iscpend(i,iint)
3074           itypj=iabs(itype(j))
3075           if (itypj.eq.ntyp1) cycle
3076 C Uncomment following three lines for SC-p interactions
3077 c         xj=c(1,nres+j)-xi
3078 c         yj=c(2,nres+j)-yi
3079 c         zj=c(3,nres+j)-zi
3080 C Uncomment following three lines for Ca-p interactions
3081           xj=c(1,j)
3082           yj=c(2,j)
3083           zj=c(3,j)
3084 C returning the jth atom to box
3085           xj=mod(xj,boxxsize)
3086           if (xj.lt.0) xj=xj+boxxsize
3087           yj=mod(yj,boxysize)
3088           if (yj.lt.0) yj=yj+boxysize
3089           zj=mod(zj,boxzsize)
3090           if (zj.lt.0) zj=zj+boxzsize
3091       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3092       xj_safe=xj
3093       yj_safe=yj
3094       zj_safe=zj
3095       subchap=0
3096 C Finding the closest jth atom
3097       do xshift=-1,1
3098       do yshift=-1,1
3099       do zshift=-1,1
3100           xj=xj_safe+xshift*boxxsize
3101           yj=yj_safe+yshift*boxysize
3102           zj=zj_safe+zshift*boxzsize
3103           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3104           if(dist_temp.lt.dist_init) then
3105             dist_init=dist_temp
3106             xj_temp=xj
3107             yj_temp=yj
3108             zj_temp=zj
3109             subchap=1
3110           endif
3111        enddo
3112        enddo
3113        enddo
3114        if (subchap.eq.1) then
3115           xj=xj_temp-xi
3116           yj=yj_temp-yi
3117           zj=zj_temp-zi
3118        else
3119           xj=xj_safe-xi
3120           yj=yj_safe-yi
3121           zj=zj_safe-zi
3122        endif
3123           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3124 C sss is scaling function for smoothing the cutoff gradient otherwise
3125 C the gradient would not be continuouse
3126           sss=sscale(1.0d0/(dsqrt(rrij)))
3127           if (sss.le.0.0d0) cycle
3128           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3129           fac=rrij**expon2
3130           e1=fac*fac*aad(itypj,iteli)
3131           e2=fac*bad(itypj,iteli)
3132           if (iabs(j-i) .le. 2) then
3133             e1=scal14*e1
3134             e2=scal14*e2
3135             evdw2_14=evdw2_14+(e1+e2)*sss
3136           endif
3137           evdwij=e1+e2
3138 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3139 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3140 c     &       bad(itypj,iteli)
3141           evdw2=evdw2+evdwij*sss
3142           if (calc_grad) then
3143 C
3144 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3145 C
3146           fac=-(evdwij+e1)*rrij*sss
3147           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3148           ggg(1)=xj*fac
3149           ggg(2)=yj*fac
3150           ggg(3)=zj*fac
3151           if (j.lt.i) then
3152 cd          write (iout,*) 'j<i'
3153 C Uncomment following three lines for SC-p interactions
3154 c           do k=1,3
3155 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3156 c           enddo
3157           else
3158 cd          write (iout,*) 'j>i'
3159             do k=1,3
3160               ggg(k)=-ggg(k)
3161 C Uncomment following line for SC-p interactions
3162 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3163             enddo
3164           endif
3165           do k=1,3
3166             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3167           enddo
3168           kstart=min0(i+1,j)
3169           kend=max0(i-1,j-1)
3170 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3171 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3172           do k=kstart,kend
3173             do l=1,3
3174               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3175             enddo
3176           enddo
3177           endif
3178         enddo
3179         enddo ! iint
3180  1225   continue
3181       enddo ! i
3182       do i=1,nct
3183         do j=1,3
3184           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3185           gradx_scp(j,i)=expon*gradx_scp(j,i)
3186         enddo
3187       enddo
3188 C******************************************************************************
3189 C
3190 C                              N O T E !!!
3191 C
3192 C To save time the factor EXPON has been extracted from ALL components
3193 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3194 C use!
3195 C
3196 C******************************************************************************
3197       return
3198       end
3199 C--------------------------------------------------------------------------
3200       subroutine edis(ehpb)
3201 C
3202 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3203 C
3204       implicit real*8 (a-h,o-z)
3205       include 'DIMENSIONS'
3206       include 'DIMENSIONS.ZSCOPT'
3207       include 'DIMENSIONS.FREE'
3208       include 'COMMON.SBRIDGE'
3209       include 'COMMON.CHAIN'
3210       include 'COMMON.DERIV'
3211       include 'COMMON.VAR'
3212       include 'COMMON.INTERACT'
3213       include 'COMMON.CONTROL'
3214       include 'COMMON.IOUNITS'
3215       dimension ggg(3)
3216       ehpb=0.0D0
3217 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3218 cd    print *,'link_start=',link_start,' link_end=',link_end
3219 C      write(iout,*) link_end, "link_end"
3220       if (link_end.eq.0) return
3221       do i=link_start,link_end
3222 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3223 C CA-CA distance used in regularization of structure.
3224         ii=ihpb(i)
3225         jj=jhpb(i)
3226 C iii and jjj point to the residues for which the distance is assigned.
3227         if (ii.gt.nres) then
3228           iii=ii-nres
3229           jjj=jj-nres
3230         else
3231           iii=ii
3232           jjj=jj
3233         endif
3234 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3235 C    distance and angle dependent SS bond potential.
3236 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3237 C     & iabs(itype(jjj)).eq.1) then
3238 C       write(iout,*) constr_dist,"const"
3239        if (.not.dyn_ss .and. i.le.nss) then
3240          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3241      & iabs(itype(jjj)).eq.1) then
3242           call ssbond_ene(iii,jjj,eij)
3243           ehpb=ehpb+2*eij
3244            endif !ii.gt.neres
3245         else if (ii.gt.nres .and. jj.gt.nres) then
3246 c Restraints from contact prediction
3247           dd=dist(ii,jj)
3248           if (constr_dist.eq.11) then
3249 C            ehpb=ehpb+fordepth(i)**4.0d0
3250 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3251             ehpb=ehpb+fordepth(i)**4.0d0
3252      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3253             fac=fordepth(i)**4.0d0
3254      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3255 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3256 C     &    ehpb,fordepth(i),dd
3257 C            write(iout,*) ehpb,"atu?"
3258 C            ehpb,"tu?"
3259 C            fac=fordepth(i)**4.0d0
3260 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3261            else
3262           if (dhpb1(i).gt.0.0d0) then
3263             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3264             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3265 c            write (iout,*) "beta nmr",
3266 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3267           else
3268             dd=dist(ii,jj)
3269             rdis=dd-dhpb(i)
3270 C Get the force constant corresponding to this distance.
3271             waga=forcon(i)
3272 C Calculate the contribution to energy.
3273             ehpb=ehpb+waga*rdis*rdis
3274 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3275 C
3276 C Evaluate gradient.
3277 C
3278             fac=waga*rdis/dd
3279           endif !end dhpb1(i).gt.0
3280           endif !end const_dist=11
3281           do j=1,3
3282             ggg(j)=fac*(c(j,jj)-c(j,ii))
3283           enddo
3284           do j=1,3
3285             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3286             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3287           enddo
3288           do k=1,3
3289             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3290             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3291           enddo
3292         else !ii.gt.nres
3293 C          write(iout,*) "before"
3294           dd=dist(ii,jj)
3295 C          write(iout,*) "after",dd
3296           if (constr_dist.eq.11) then
3297             ehpb=ehpb+fordepth(i)**4.0d0
3298      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3299             fac=fordepth(i)**4.0d0
3300      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3301 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3302 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3303 C            print *,ehpb,"tu?"
3304 C            write(iout,*) ehpb,"btu?",
3305 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3306 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3307 C     &    ehpb,fordepth(i),dd
3308            else
3309           if (dhpb1(i).gt.0.0d0) then
3310             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3311             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3312 c            write (iout,*) "alph nmr",
3313 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3314           else
3315             rdis=dd-dhpb(i)
3316 C Get the force constant corresponding to this distance.
3317             waga=forcon(i)
3318 C Calculate the contribution to energy.
3319             ehpb=ehpb+waga*rdis*rdis
3320 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3321 C
3322 C Evaluate gradient.
3323 C
3324             fac=waga*rdis/dd
3325           endif
3326           endif
3327
3328         do j=1,3
3329           ggg(j)=fac*(c(j,jj)-c(j,ii))
3330         enddo
3331 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3332 C If this is a SC-SC distance, we need to calculate the contributions to the
3333 C Cartesian gradient in the SC vectors (ghpbx).
3334         if (iii.lt.ii) then
3335           do j=1,3
3336             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3337             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3338           enddo
3339         endif
3340         do j=iii,jjj-1
3341           do k=1,3
3342             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3343           enddo
3344         enddo
3345         endif
3346       enddo
3347       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3348       return
3349       end
3350 C--------------------------------------------------------------------------
3351       subroutine ssbond_ene(i,j,eij)
3352 C
3353 C Calculate the distance and angle dependent SS-bond potential energy
3354 C using a free-energy function derived based on RHF/6-31G** ab initio
3355 C calculations of diethyl disulfide.
3356 C
3357 C A. Liwo and U. Kozlowska, 11/24/03
3358 C
3359       implicit real*8 (a-h,o-z)
3360       include 'DIMENSIONS'
3361       include 'DIMENSIONS.ZSCOPT'
3362       include 'COMMON.SBRIDGE'
3363       include 'COMMON.CHAIN'
3364       include 'COMMON.DERIV'
3365       include 'COMMON.LOCAL'
3366       include 'COMMON.INTERACT'
3367       include 'COMMON.VAR'
3368       include 'COMMON.IOUNITS'
3369       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3370       itypi=iabs(itype(i))
3371       xi=c(1,nres+i)
3372       yi=c(2,nres+i)
3373       zi=c(3,nres+i)
3374       dxi=dc_norm(1,nres+i)
3375       dyi=dc_norm(2,nres+i)
3376       dzi=dc_norm(3,nres+i)
3377       dsci_inv=dsc_inv(itypi)
3378       itypj=iabs(itype(j))
3379       dscj_inv=dsc_inv(itypj)
3380       xj=c(1,nres+j)-xi
3381       yj=c(2,nres+j)-yi
3382       zj=c(3,nres+j)-zi
3383       dxj=dc_norm(1,nres+j)
3384       dyj=dc_norm(2,nres+j)
3385       dzj=dc_norm(3,nres+j)
3386       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3387       rij=dsqrt(rrij)
3388       erij(1)=xj*rij
3389       erij(2)=yj*rij
3390       erij(3)=zj*rij
3391       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3392       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3393       om12=dxi*dxj+dyi*dyj+dzi*dzj
3394       do k=1,3
3395         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3396         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3397       enddo
3398       rij=1.0d0/rij
3399       deltad=rij-d0cm
3400       deltat1=1.0d0-om1
3401       deltat2=1.0d0+om2
3402       deltat12=om2-om1+2.0d0
3403       cosphi=om12-om1*om2
3404       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3405      &  +akct*deltad*deltat12
3406      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3407 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3408 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3409 c     &  " deltat12",deltat12," eij",eij
3410       ed=2*akcm*deltad+akct*deltat12
3411       pom1=akct*deltad
3412       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3413       eom1=-2*akth*deltat1-pom1-om2*pom2
3414       eom2= 2*akth*deltat2+pom1-om1*pom2
3415       eom12=pom2
3416       do k=1,3
3417         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3418       enddo
3419       do k=1,3
3420         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3421      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3422         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3423      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3424       enddo
3425 C
3426 C Calculate the components of the gradient in DC and X
3427 C
3428       do k=i,j-1
3429         do l=1,3
3430           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3431         enddo
3432       enddo
3433       return
3434       end
3435 C--------------------------------------------------------------------------
3436 c MODELLER restraint function
3437       subroutine e_modeller(ehomology_constr)
3438       implicit real*8 (a-h,o-z)
3439       include 'DIMENSIONS'
3440       include 'DIMENSIONS.ZSCOPT'
3441       include 'DIMENSIONS.FREE'
3442       integer nnn, i, j, k, ki, irec, l
3443       integer katy, odleglosci, test7
3444       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3445       real*8 distance(max_template),distancek(max_template),
3446      &    min_odl,godl(max_template),dih_diff(max_template)
3447
3448 c
3449 c     FP - 30/10/2014 Temporary specifications for homology restraints
3450 c
3451       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3452      &                 sgtheta
3453       double precision, dimension (maxres) :: guscdiff,usc_diff
3454       double precision, dimension (max_template) ::
3455      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3456      &           theta_diff
3457
3458       include 'COMMON.SBRIDGE'
3459       include 'COMMON.CHAIN'
3460       include 'COMMON.GEO'
3461       include 'COMMON.DERIV'
3462       include 'COMMON.LOCAL'
3463       include 'COMMON.INTERACT'
3464       include 'COMMON.VAR'
3465       include 'COMMON.IOUNITS'
3466       include 'COMMON.CONTROL'
3467       include 'COMMON.HOMRESTR'
3468 c
3469       include 'COMMON.SETUP'
3470       include 'COMMON.NAMES'
3471
3472       do i=1,max_template
3473         distancek(i)=9999999.9
3474       enddo
3475
3476       odleg=0.0d0
3477
3478 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3479 c function)
3480 C AL 5/2/14 - Introduce list of restraints
3481 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3482 #ifdef DEBUG
3483       write(iout,*) "------- dist restrs start -------"
3484 #endif
3485       do ii = link_start_homo,link_end_homo
3486          i = ires_homo(ii)
3487          j = jres_homo(ii)
3488          dij=dist(i,j)
3489 c        write (iout,*) "dij(",i,j,") =",dij
3490          do k=1,constr_homology
3491            if(.not.l_homo(k,ii)) cycle
3492            distance(k)=odl(k,ii)-dij
3493 c          write (iout,*) "distance(",k,") =",distance(k)
3494 c
3495 c          For Gaussian-type Urestr
3496 c
3497            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3498 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3499 c          write (iout,*) "distancek(",k,") =",distancek(k)
3500 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3501 c
3502 c          For Lorentzian-type Urestr
3503 c
3504            if (waga_dist.lt.0.0d0) then
3505               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3506               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3507      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3508            endif
3509          enddo
3510
3511 c         min_odl=minval(distancek)
3512          do kk=1,constr_homology
3513           if(l_homo(kk,ii)) then
3514             min_odl=distancek(kk)
3515             exit
3516           endif
3517          enddo
3518          do kk=1,constr_homology
3519           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3520      &              min_odl=distancek(kk)
3521          enddo
3522 c        write (iout,* )"min_odl",min_odl
3523 #ifdef DEBUG
3524          write (iout,*) "ij dij",i,j,dij
3525          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3526          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3527          write (iout,* )"min_odl",min_odl
3528 #endif
3529          odleg2=0.0d0
3530          do k=1,constr_homology
3531 c Nie wiem po co to liczycie jeszcze raz!
3532 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3533 c     &              (2*(sigma_odl(i,j,k))**2))
3534            if(.not.l_homo(k,ii)) cycle
3535            if (waga_dist.ge.0.0d0) then
3536 c
3537 c          For Gaussian-type Urestr
3538 c
3539             godl(k)=dexp(-distancek(k)+min_odl)
3540             odleg2=odleg2+godl(k)
3541 c
3542 c          For Lorentzian-type Urestr
3543 c
3544            else
3545             odleg2=odleg2+distancek(k)
3546            endif
3547
3548 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3549 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3550 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3551 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3552
3553          enddo
3554 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3555 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3556 #ifdef DEBUG
3557          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3558          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3559 #endif
3560            if (waga_dist.ge.0.0d0) then
3561 c
3562 c          For Gaussian-type Urestr
3563 c
3564               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3565 c
3566 c          For Lorentzian-type Urestr
3567 c
3568            else
3569               odleg=odleg+odleg2/constr_homology
3570            endif
3571 c
3572 #ifdef GRAD
3573 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3574 c Gradient
3575 c
3576 c          For Gaussian-type Urestr
3577 c
3578          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3579          sum_sgodl=0.0d0
3580          do k=1,constr_homology
3581 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3582 c     &           *waga_dist)+min_odl
3583 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3584 c
3585          if(.not.l_homo(k,ii)) cycle
3586          if (waga_dist.ge.0.0d0) then
3587 c          For Gaussian-type Urestr
3588 c
3589            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3590 c
3591 c          For Lorentzian-type Urestr
3592 c
3593          else
3594            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3595      &           sigma_odlir(k,ii)**2)**2)
3596          endif
3597            sum_sgodl=sum_sgodl+sgodl
3598
3599 c            sgodl2=sgodl2+sgodl
3600 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3601 c      write(iout,*) "constr_homology=",constr_homology
3602 c      write(iout,*) i, j, k, "TEST K"
3603          enddo
3604          if (waga_dist.ge.0.0d0) then
3605 c
3606 c          For Gaussian-type Urestr
3607 c
3608             grad_odl3=waga_homology(iset)*waga_dist
3609      &                *sum_sgodl/(sum_godl*dij)
3610 c
3611 c          For Lorentzian-type Urestr
3612 c
3613          else
3614 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3615 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3616             grad_odl3=-waga_homology(iset)*waga_dist*
3617      &                sum_sgodl/(constr_homology*dij)
3618          endif
3619 c
3620 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3621
3622
3623 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3624 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3625 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3626
3627 ccc      write(iout,*) godl, sgodl, grad_odl3
3628
3629 c          grad_odl=grad_odl+grad_odl3
3630
3631          do jik=1,3
3632             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3633 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3634 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3635 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3636             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3637             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3638 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3639 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3640 c         if (i.eq.25.and.j.eq.27) then
3641 c         write(iout,*) "jik",jik,"i",i,"j",j
3642 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3643 c         write(iout,*) "grad_odl3",grad_odl3
3644 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3645 c         write(iout,*) "ggodl",ggodl
3646 c         write(iout,*) "ghpbc(",jik,i,")",
3647 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3648 c     &                 ghpbc(jik,j)
3649 c         endif
3650          enddo
3651 #endif
3652 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3653 ccc     & dLOG(odleg2),"-odleg=", -odleg
3654
3655       enddo ! ii-loop for dist
3656 #ifdef DEBUG
3657       write(iout,*) "------- dist restrs end -------"
3658 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3659 c    &     waga_d.eq.1.0d0) call sum_gradient
3660 #endif
3661 c Pseudo-energy and gradient from dihedral-angle restraints from
3662 c homology templates
3663 c      write (iout,*) "End of distance loop"
3664 c      call flush(iout)
3665       kat=0.0d0
3666 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3667 #ifdef DEBUG
3668       write(iout,*) "------- dih restrs start -------"
3669       do i=idihconstr_start_homo,idihconstr_end_homo
3670         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3671       enddo
3672 #endif
3673       do i=idihconstr_start_homo,idihconstr_end_homo
3674         kat2=0.0d0
3675 c        betai=beta(i,i+1,i+2,i+3)
3676         betai = phi(i)
3677 c       write (iout,*) "betai =",betai
3678         do k=1,constr_homology
3679           dih_diff(k)=pinorm(dih(k,i)-betai)
3680 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3681 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3682 c     &                                   -(6.28318-dih_diff(i,k))
3683 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3684 c     &                                   6.28318+dih_diff(i,k)
3685
3686           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3687 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3688           gdih(k)=dexp(kat3)
3689           kat2=kat2+gdih(k)
3690 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3691 c          write(*,*)""
3692         enddo
3693 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3694 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3695 #ifdef DEBUG
3696         write (iout,*) "i",i," betai",betai," kat2",kat2
3697         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3698 #endif
3699         if (kat2.le.1.0d-14) cycle
3700         kat=kat-dLOG(kat2/constr_homology)
3701 c       write (iout,*) "kat",kat ! sum of -ln-s
3702
3703 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3704 ccc     & dLOG(kat2), "-kat=", -kat
3705
3706 #ifdef GRAD
3707 c ----------------------------------------------------------------------
3708 c Gradient
3709 c ----------------------------------------------------------------------
3710
3711         sum_gdih=kat2
3712         sum_sgdih=0.0d0
3713         do k=1,constr_homology
3714           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3715 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3716           sum_sgdih=sum_sgdih+sgdih
3717         enddo
3718 c       grad_dih3=sum_sgdih/sum_gdih
3719         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3720
3721 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3722 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3723 ccc     & gloc(nphi+i-3,icg)
3724         gloc(i,icg)=gloc(i,icg)+grad_dih3
3725 c        if (i.eq.25) then
3726 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3727 c        endif
3728 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3729 ccc     & gloc(nphi+i-3,icg)
3730 #endif
3731       enddo ! i-loop for dih
3732 #ifdef DEBUG
3733       write(iout,*) "------- dih restrs end -------"
3734 #endif
3735
3736 c Pseudo-energy and gradient for theta angle restraints from
3737 c homology templates
3738 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3739 c adapted
3740
3741 c
3742 c     For constr_homology reference structures (FP)
3743 c
3744 c     Uconst_back_tot=0.0d0
3745       Eval=0.0d0
3746       Erot=0.0d0
3747 c     Econstr_back legacy
3748 #ifdef GRAD
3749       do i=1,nres
3750 c     do i=ithet_start,ithet_end
3751        dutheta(i)=0.0d0
3752 c     enddo
3753 c     do i=loc_start,loc_end
3754         do j=1,3
3755           duscdiff(j,i)=0.0d0
3756           duscdiffx(j,i)=0.0d0
3757         enddo
3758       enddo
3759 #endif
3760 c
3761 c     do iref=1,nref
3762 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3763 c     write (iout,*) "waga_theta",waga_theta
3764       if (waga_theta.gt.0.0d0) then
3765 #ifdef DEBUG
3766       write (iout,*) "usampl",usampl
3767       write(iout,*) "------- theta restrs start -------"
3768 c     do i=ithet_start,ithet_end
3769 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3770 c     enddo
3771 #endif
3772 c     write (iout,*) "maxres",maxres,"nres",nres
3773
3774       do i=ithet_start,ithet_end
3775 c
3776 c     do i=1,nfrag_back
3777 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3778 c
3779 c Deviation of theta angles wrt constr_homology ref structures
3780 c
3781         utheta_i=0.0d0 ! argument of Gaussian for single k
3782         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3783 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3784 c       over residues in a fragment
3785 c       write (iout,*) "theta(",i,")=",theta(i)
3786         do k=1,constr_homology
3787 c
3788 c         dtheta_i=theta(j)-thetaref(j,iref)
3789 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3790           theta_diff(k)=thetatpl(k,i)-theta(i)
3791 c
3792           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3793 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3794           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3795           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3796 c         Gradient for single Gaussian restraint in subr Econstr_back
3797 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3798 c
3799         enddo
3800 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3801 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3802
3803 c
3804 #ifdef GRAD
3805 c         Gradient for multiple Gaussian restraint
3806         sum_gtheta=gutheta_i
3807         sum_sgtheta=0.0d0
3808         do k=1,constr_homology
3809 c        New generalized expr for multiple Gaussian from Econstr_back
3810          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3811 c
3812 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3813           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3814         enddo
3815 c
3816 c       Final value of gradient using same var as in Econstr_back
3817         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3818      &               *waga_homology(iset)
3819 c       dutheta(i)=sum_sgtheta/sum_gtheta
3820 c
3821 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3822 #endif
3823         Eval=Eval-dLOG(gutheta_i/constr_homology)
3824 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3825 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3826 c       Uconst_back=Uconst_back+utheta(i)
3827       enddo ! (i-loop for theta)
3828 #ifdef DEBUG
3829       write(iout,*) "------- theta restrs end -------"
3830 #endif
3831       endif
3832 c
3833 c Deviation of local SC geometry
3834 c
3835 c Separation of two i-loops (instructed by AL - 11/3/2014)
3836 c
3837 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3838 c     write (iout,*) "waga_d",waga_d
3839
3840 #ifdef DEBUG
3841       write(iout,*) "------- SC restrs start -------"
3842       write (iout,*) "Initial duscdiff,duscdiffx"
3843       do i=loc_start,loc_end
3844         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3845      &                 (duscdiffx(jik,i),jik=1,3)
3846       enddo
3847 #endif
3848       do i=loc_start,loc_end
3849         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3850         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3851 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3852 c       write(iout,*) "xxtab, yytab, zztab"
3853 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3854         do k=1,constr_homology
3855 c
3856           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3857 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3858           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3859           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3860 c         write(iout,*) "dxx, dyy, dzz"
3861 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3862 c
3863           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3864 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3865 c         uscdiffk(k)=usc_diff(i)
3866           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3867           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3868 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3869 c     &      xxref(j),yyref(j),zzref(j)
3870         enddo
3871 c
3872 c       Gradient
3873 c
3874 c       Generalized expression for multiple Gaussian acc to that for a single
3875 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3876 c
3877 c       Original implementation
3878 c       sum_guscdiff=guscdiff(i)
3879 c
3880 c       sum_sguscdiff=0.0d0
3881 c       do k=1,constr_homology
3882 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3883 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3884 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3885 c       enddo
3886 c
3887 c       Implementation of new expressions for gradient (Jan. 2015)
3888 c
3889 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3890 #ifdef GRAD
3891         do k=1,constr_homology
3892 c
3893 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3894 c       before. Now the drivatives should be correct
3895 c
3896           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3897 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3898           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3899           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3900 c
3901 c         New implementation
3902 c
3903           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3904      &                 sigma_d(k,i) ! for the grad wrt r'
3905 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3906 c
3907 c
3908 c        New implementation
3909          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3910          do jik=1,3
3911             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3912      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3913      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3914             duscdiff(jik,i)=duscdiff(jik,i)+
3915      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3916      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3917             duscdiffx(jik,i)=duscdiffx(jik,i)+
3918      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3919      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3920 c
3921 #ifdef DEBUG
3922              write(iout,*) "jik",jik,"i",i
3923              write(iout,*) "dxx, dyy, dzz"
3924              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3925              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3926 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3927 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3928 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3929 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3930 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3931 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3932 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3933 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3934 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3935 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3936 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3937 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3938 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3939 c            endif
3940 #endif
3941          enddo
3942         enddo
3943 #endif
3944 c
3945 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3946 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3947 c
3948 c        write (iout,*) i," uscdiff",uscdiff(i)
3949 c
3950 c Put together deviations from local geometry
3951
3952 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3953 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3954         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3955 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3956 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3957 c       Uconst_back=Uconst_back+usc_diff(i)
3958 c
3959 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3960 c
3961 c     New implment: multiplied by sum_sguscdiff
3962 c
3963
3964       enddo ! (i-loop for dscdiff)
3965
3966 c      endif
3967
3968 #ifdef DEBUG
3969       write(iout,*) "------- SC restrs end -------"
3970         write (iout,*) "------ After SC loop in e_modeller ------"
3971         do i=loc_start,loc_end
3972          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3973          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3974         enddo
3975       if (waga_theta.eq.1.0d0) then
3976       write (iout,*) "in e_modeller after SC restr end: dutheta"
3977       do i=ithet_start,ithet_end
3978         write (iout,*) i,dutheta(i)
3979       enddo
3980       endif
3981       if (waga_d.eq.1.0d0) then
3982       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3983       do i=1,nres
3984         write (iout,*) i,(duscdiff(j,i),j=1,3)
3985         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3986       enddo
3987       endif
3988 #endif
3989
3990 c Total energy from homology restraints
3991 #ifdef DEBUG
3992       write (iout,*) "odleg",odleg," kat",kat
3993       write (iout,*) "odleg",odleg," kat",kat
3994       write (iout,*) "Eval",Eval," Erot",Erot
3995       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3996       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3997       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3998 #endif
3999 c
4000 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4001 c
4002 c     ehomology_constr=odleg+kat
4003 c
4004 c     For Lorentzian-type Urestr
4005 c
4006
4007       if (waga_dist.ge.0.0d0) then
4008 c
4009 c          For Gaussian-type Urestr
4010 c
4011 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4012 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4013         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4014      &              waga_theta*Eval+waga_d*Erot
4015 c     write (iout,*) "ehomology_constr=",ehomology_constr
4016       else
4017 c
4018 c          For Lorentzian-type Urestr
4019 c
4020 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4021 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4022         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4023      &              waga_theta*Eval+waga_d*Erot
4024 c     write (iout,*) "ehomology_constr=",ehomology_constr
4025       endif
4026 #ifdef DEBUG
4027       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4028      & "Eval",waga_theta,eval,
4029      &   "Erot",waga_d,Erot
4030       write (iout,*) "ehomology_constr",ehomology_constr
4031 #endif
4032       return
4033
4034   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4035   747 format(a12,i4,i4,i4,f8.3,f8.3)
4036   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4037   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4038   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4039      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4040       end
4041 c-----------------------------------------------------------------------
4042       subroutine ebond(estr)
4043 c
4044 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4045 c
4046       implicit real*8 (a-h,o-z)
4047       include 'DIMENSIONS'
4048       include 'DIMENSIONS.ZSCOPT'
4049       include 'DIMENSIONS.FREE'
4050       include 'COMMON.LOCAL'
4051       include 'COMMON.GEO'
4052       include 'COMMON.INTERACT'
4053       include 'COMMON.DERIV'
4054       include 'COMMON.VAR'
4055       include 'COMMON.CHAIN'
4056       include 'COMMON.IOUNITS'
4057       include 'COMMON.NAMES'
4058       include 'COMMON.FFIELD'
4059       include 'COMMON.CONTROL'
4060       logical energy_dec /.false./
4061       double precision u(3),ud(3)
4062       estr=0.0d0
4063 C      write (iout,*) "distchainmax",distchainmax
4064       estr1=0.0d0
4065 c      write (iout,*) "distchainmax",distchainmax
4066       do i=nnt+1,nct
4067         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4068 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4069 C          do j=1,3
4070 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4071 C     &      *dc(j,i-1)/vbld(i)
4072 C          enddo
4073 C          if (energy_dec) write(iout,*)
4074 C     &       "estr1",i,vbld(i),distchainmax,
4075 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4076 C        else
4077          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4078         diff = vbld(i)-vbldpDUM
4079 C         write(iout,*) i,diff
4080          else
4081           diff = vbld(i)-vbldp0
4082 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4083          endif
4084           estr=estr+diff*diff
4085           do j=1,3
4086             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4087           enddo
4088 C        endif
4089 C        write (iout,'(a7,i5,4f7.3)')
4090 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4091       enddo
4092       estr=0.5d0*AKP*estr+estr1
4093 c
4094 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4095 c
4096       do i=nnt,nct
4097         iti=iabs(itype(i))
4098         if (iti.ne.10 .and. iti.ne.ntyp1) then
4099           nbi=nbondterm(iti)
4100           if (nbi.eq.1) then
4101             diff=vbld(i+nres)-vbldsc0(1,iti)
4102 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4103 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4104             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4105             do j=1,3
4106               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4107             enddo
4108           else
4109             do j=1,nbi
4110               diff=vbld(i+nres)-vbldsc0(j,iti)
4111               ud(j)=aksc(j,iti)*diff
4112               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4113             enddo
4114             uprod=u(1)
4115             do j=2,nbi
4116               uprod=uprod*u(j)
4117             enddo
4118             usum=0.0d0
4119             usumsqder=0.0d0
4120             do j=1,nbi
4121               uprod1=1.0d0
4122               uprod2=1.0d0
4123               do k=1,nbi
4124                 if (k.ne.j) then
4125                   uprod1=uprod1*u(k)
4126                   uprod2=uprod2*u(k)*u(k)
4127                 endif
4128               enddo
4129               usum=usum+uprod1
4130               usumsqder=usumsqder+ud(j)*uprod2
4131             enddo
4132 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4133 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4134             estr=estr+uprod/usum
4135             do j=1,3
4136              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4137             enddo
4138           endif
4139         endif
4140       enddo
4141       return
4142       end
4143 #ifdef CRYST_THETA
4144 C--------------------------------------------------------------------------
4145       subroutine ebend(etheta)
4146 C
4147 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4148 C angles gamma and its derivatives in consecutive thetas and gammas.
4149 C
4150       implicit real*8 (a-h,o-z)
4151       include 'DIMENSIONS'
4152       include 'DIMENSIONS.ZSCOPT'
4153       include 'COMMON.LOCAL'
4154       include 'COMMON.GEO'
4155       include 'COMMON.INTERACT'
4156       include 'COMMON.DERIV'
4157       include 'COMMON.VAR'
4158       include 'COMMON.CHAIN'
4159       include 'COMMON.IOUNITS'
4160       include 'COMMON.NAMES'
4161       include 'COMMON.FFIELD'
4162       common /calcthet/ term1,term2,termm,diffak,ratak,
4163      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4164      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4165       double precision y(2),z(2)
4166       delta=0.02d0*pi
4167       time11=dexp(-2*time)
4168       time12=1.0d0
4169       etheta=0.0D0
4170 c      write (iout,*) "nres",nres
4171 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4172 c      write (iout,*) ithet_start,ithet_end
4173       do i=ithet_start,ithet_end
4174 C        if (itype(i-1).eq.ntyp1) cycle
4175         if (i.le.2) cycle
4176         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4177      &  .or.itype(i).eq.ntyp1) cycle
4178 C Zero the energy function and its derivative at 0 or pi.
4179         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4180         it=itype(i-1)
4181         ichir1=isign(1,itype(i-2))
4182         ichir2=isign(1,itype(i))
4183          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4184          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4185          if (itype(i-1).eq.10) then
4186           itype1=isign(10,itype(i-2))
4187           ichir11=isign(1,itype(i-2))
4188           ichir12=isign(1,itype(i-2))
4189           itype2=isign(10,itype(i))
4190           ichir21=isign(1,itype(i))
4191           ichir22=isign(1,itype(i))
4192          endif
4193          if (i.eq.3) then
4194           y(1)=0.0D0
4195           y(2)=0.0D0
4196           else
4197
4198         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4199 #ifdef OSF
4200           phii=phi(i)
4201 c          icrc=0
4202 c          call proc_proc(phii,icrc)
4203           if (icrc.eq.1) phii=150.0
4204 #else
4205           phii=phi(i)
4206 #endif
4207           y(1)=dcos(phii)
4208           y(2)=dsin(phii)
4209         else
4210           y(1)=0.0D0
4211           y(2)=0.0D0
4212         endif
4213         endif
4214         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4215 #ifdef OSF
4216           phii1=phi(i+1)
4217 c          icrc=0
4218 c          call proc_proc(phii1,icrc)
4219           if (icrc.eq.1) phii1=150.0
4220           phii1=pinorm(phii1)
4221           z(1)=cos(phii1)
4222 #else
4223           phii1=phi(i+1)
4224           z(1)=dcos(phii1)
4225 #endif
4226           z(2)=dsin(phii1)
4227         else
4228           z(1)=0.0D0
4229           z(2)=0.0D0
4230         endif
4231 C Calculate the "mean" value of theta from the part of the distribution
4232 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4233 C In following comments this theta will be referred to as t_c.
4234         thet_pred_mean=0.0d0
4235         do k=1,2
4236             athetk=athet(k,it,ichir1,ichir2)
4237             bthetk=bthet(k,it,ichir1,ichir2)
4238           if (it.eq.10) then
4239              athetk=athet(k,itype1,ichir11,ichir12)
4240              bthetk=bthet(k,itype2,ichir21,ichir22)
4241           endif
4242           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4243         enddo
4244 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4245         dthett=thet_pred_mean*ssd
4246         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4247 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4248 C Derivatives of the "mean" values in gamma1 and gamma2.
4249         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4250      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4251          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4252      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4253          if (it.eq.10) then
4254       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4255      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4256         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4257      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4258          endif
4259         if (theta(i).gt.pi-delta) then
4260           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4261      &         E_tc0)
4262           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4263           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4264           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4265      &        E_theta)
4266           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4267      &        E_tc)
4268         else if (theta(i).lt.delta) then
4269           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4270           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4271           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4272      &        E_theta)
4273           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4274           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4275      &        E_tc)
4276         else
4277           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4278      &        E_theta,E_tc)
4279         endif
4280         etheta=etheta+ethetai
4281 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4282 c     &      'ebend',i,ethetai,theta(i),itype(i)
4283 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4284 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4285         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4286         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4287         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4288 c 1215   continue
4289       enddo
4290       ethetacnstr=0.0d0
4291 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4292       do i=1,ntheta_constr
4293         itheta=itheta_constr(i)
4294         thetiii=theta(itheta)
4295         difi=pinorm(thetiii-theta_constr0(i))
4296         if (difi.gt.theta_drange(i)) then
4297           difi=difi-theta_drange(i)
4298           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4299           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4300      &    +for_thet_constr(i)*difi**3
4301         else if (difi.lt.-drange(i)) then
4302           difi=difi+drange(i)
4303           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4304           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4305      &    +for_thet_constr(i)*difi**3
4306         else
4307           difi=0.0
4308         endif
4309 C       if (energy_dec) then
4310 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4311 C     &    i,itheta,rad2deg*thetiii,
4312 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4313 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4314 C     &    gloc(itheta+nphi-2,icg)
4315 C        endif
4316       enddo
4317 C Ufff.... We've done all this!!!
4318       return
4319       end
4320 C---------------------------------------------------------------------------
4321       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4322      &     E_tc)
4323       implicit real*8 (a-h,o-z)
4324       include 'DIMENSIONS'
4325       include 'COMMON.LOCAL'
4326       include 'COMMON.IOUNITS'
4327       common /calcthet/ term1,term2,termm,diffak,ratak,
4328      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4329      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4330 C Calculate the contributions to both Gaussian lobes.
4331 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4332 C The "polynomial part" of the "standard deviation" of this part of
4333 C the distribution.
4334         sig=polthet(3,it)
4335         do j=2,0,-1
4336           sig=sig*thet_pred_mean+polthet(j,it)
4337         enddo
4338 C Derivative of the "interior part" of the "standard deviation of the"
4339 C gamma-dependent Gaussian lobe in t_c.
4340         sigtc=3*polthet(3,it)
4341         do j=2,1,-1
4342           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4343         enddo
4344         sigtc=sig*sigtc
4345 C Set the parameters of both Gaussian lobes of the distribution.
4346 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4347         fac=sig*sig+sigc0(it)
4348         sigcsq=fac+fac
4349         sigc=1.0D0/sigcsq
4350 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4351         sigsqtc=-4.0D0*sigcsq*sigtc
4352 c       print *,i,sig,sigtc,sigsqtc
4353 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4354         sigtc=-sigtc/(fac*fac)
4355 C Following variable is sigma(t_c)**(-2)
4356         sigcsq=sigcsq*sigcsq
4357         sig0i=sig0(it)
4358         sig0inv=1.0D0/sig0i**2
4359         delthec=thetai-thet_pred_mean
4360         delthe0=thetai-theta0i
4361         term1=-0.5D0*sigcsq*delthec*delthec
4362         term2=-0.5D0*sig0inv*delthe0*delthe0
4363 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4364 C NaNs in taking the logarithm. We extract the largest exponent which is added
4365 C to the energy (this being the log of the distribution) at the end of energy
4366 C term evaluation for this virtual-bond angle.
4367         if (term1.gt.term2) then
4368           termm=term1
4369           term2=dexp(term2-termm)
4370           term1=1.0d0
4371         else
4372           termm=term2
4373           term1=dexp(term1-termm)
4374           term2=1.0d0
4375         endif
4376 C The ratio between the gamma-independent and gamma-dependent lobes of
4377 C the distribution is a Gaussian function of thet_pred_mean too.
4378         diffak=gthet(2,it)-thet_pred_mean
4379         ratak=diffak/gthet(3,it)**2
4380         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4381 C Let's differentiate it in thet_pred_mean NOW.
4382         aktc=ak*ratak
4383 C Now put together the distribution terms to make complete distribution.
4384         termexp=term1+ak*term2
4385         termpre=sigc+ak*sig0i
4386 C Contribution of the bending energy from this theta is just the -log of
4387 C the sum of the contributions from the two lobes and the pre-exponential
4388 C factor. Simple enough, isn't it?
4389         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4390 C NOW the derivatives!!!
4391 C 6/6/97 Take into account the deformation.
4392         E_theta=(delthec*sigcsq*term1
4393      &       +ak*delthe0*sig0inv*term2)/termexp
4394         E_tc=((sigtc+aktc*sig0i)/termpre
4395      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4396      &       aktc*term2)/termexp)
4397       return
4398       end
4399 c-----------------------------------------------------------------------------
4400       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4401       implicit real*8 (a-h,o-z)
4402       include 'DIMENSIONS'
4403       include 'COMMON.LOCAL'
4404       include 'COMMON.IOUNITS'
4405       common /calcthet/ term1,term2,termm,diffak,ratak,
4406      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4407      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4408       delthec=thetai-thet_pred_mean
4409       delthe0=thetai-theta0i
4410 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4411       t3 = thetai-thet_pred_mean
4412       t6 = t3**2
4413       t9 = term1
4414       t12 = t3*sigcsq
4415       t14 = t12+t6*sigsqtc
4416       t16 = 1.0d0
4417       t21 = thetai-theta0i
4418       t23 = t21**2
4419       t26 = term2
4420       t27 = t21*t26
4421       t32 = termexp
4422       t40 = t32**2
4423       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4424      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4425      & *(-t12*t9-ak*sig0inv*t27)
4426       return
4427       end
4428 #else
4429 C--------------------------------------------------------------------------
4430       subroutine ebend(etheta)
4431 C
4432 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4433 C angles gamma and its derivatives in consecutive thetas and gammas.
4434 C ab initio-derived potentials from
4435 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4436 C
4437       implicit real*8 (a-h,o-z)
4438       include 'DIMENSIONS'
4439       include 'DIMENSIONS.ZSCOPT'
4440       include 'DIMENSIONS.FREE'
4441       include 'COMMON.LOCAL'
4442       include 'COMMON.GEO'
4443       include 'COMMON.INTERACT'
4444       include 'COMMON.DERIV'
4445       include 'COMMON.VAR'
4446       include 'COMMON.CHAIN'
4447       include 'COMMON.IOUNITS'
4448       include 'COMMON.NAMES'
4449       include 'COMMON.FFIELD'
4450       include 'COMMON.CONTROL'
4451       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4452      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4453      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4454      & sinph1ph2(maxdouble,maxdouble)
4455       logical lprn /.false./, lprn1 /.false./
4456       etheta=0.0D0
4457 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4458       do i=ithet_start,ithet_end
4459         if (i.eq.2) cycle
4460 c        print *,i,itype(i-1),itype(i),itype(i-2)
4461         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4462      &  .or.(itype(i).eq.ntyp1)) cycle
4463 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4464
4465         if (iabs(itype(i+1)).eq.20) iblock=2
4466         if (iabs(itype(i+1)).ne.20) iblock=1
4467         dethetai=0.0d0
4468         dephii=0.0d0
4469         dephii1=0.0d0
4470         theti2=0.5d0*theta(i)
4471         ityp2=ithetyp((itype(i-1)))
4472         do k=1,nntheterm
4473           coskt(k)=dcos(k*theti2)
4474           sinkt(k)=dsin(k*theti2)
4475         enddo
4476         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4477 #ifdef OSF
4478           phii=phi(i)
4479           if (phii.ne.phii) phii=150.0
4480 #else
4481           phii=phi(i)
4482 #endif
4483           ityp1=ithetyp((itype(i-2)))
4484           do k=1,nsingle
4485             cosph1(k)=dcos(k*phii)
4486             sinph1(k)=dsin(k*phii)
4487           enddo
4488         else
4489           phii=0.0d0
4490           ityp1=nthetyp+1
4491           do k=1,nsingle
4492             cosph1(k)=0.0d0
4493             sinph1(k)=0.0d0
4494           enddo
4495         endif
4496         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4497 #ifdef OSF
4498           phii1=phi(i+1)
4499           if (phii1.ne.phii1) phii1=150.0
4500           phii1=pinorm(phii1)
4501 #else
4502           phii1=phi(i+1)
4503 #endif
4504           ityp3=ithetyp((itype(i)))
4505           do k=1,nsingle
4506             cosph2(k)=dcos(k*phii1)
4507             sinph2(k)=dsin(k*phii1)
4508           enddo
4509         else
4510           phii1=0.0d0
4511           ityp3=nthetyp+1
4512           do k=1,nsingle
4513             cosph2(k)=0.0d0
4514             sinph2(k)=0.0d0
4515           enddo
4516         endif
4517 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4518 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4519 c        call flush(iout)
4520         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4521         do k=1,ndouble
4522           do l=1,k-1
4523             ccl=cosph1(l)*cosph2(k-l)
4524             ssl=sinph1(l)*sinph2(k-l)
4525             scl=sinph1(l)*cosph2(k-l)
4526             csl=cosph1(l)*sinph2(k-l)
4527             cosph1ph2(l,k)=ccl-ssl
4528             cosph1ph2(k,l)=ccl+ssl
4529             sinph1ph2(l,k)=scl+csl
4530             sinph1ph2(k,l)=scl-csl
4531           enddo
4532         enddo
4533         if (lprn) then
4534         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4535      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4536         write (iout,*) "coskt and sinkt"
4537         do k=1,nntheterm
4538           write (iout,*) k,coskt(k),sinkt(k)
4539         enddo
4540         endif
4541         do k=1,ntheterm
4542           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4543           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4544      &      *coskt(k)
4545           if (lprn)
4546      &    write (iout,*) "k",k,"
4547      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4548      &     " ethetai",ethetai
4549         enddo
4550         if (lprn) then
4551         write (iout,*) "cosph and sinph"
4552         do k=1,nsingle
4553           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4554         enddo
4555         write (iout,*) "cosph1ph2 and sinph2ph2"
4556         do k=2,ndouble
4557           do l=1,k-1
4558             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4559      &         sinph1ph2(l,k),sinph1ph2(k,l)
4560           enddo
4561         enddo
4562         write(iout,*) "ethetai",ethetai
4563         endif
4564         do m=1,ntheterm2
4565           do k=1,nsingle
4566             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4567      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4568      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4569      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4570             ethetai=ethetai+sinkt(m)*aux
4571             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4572             dephii=dephii+k*sinkt(m)*(
4573      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4574      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4575             dephii1=dephii1+k*sinkt(m)*(
4576      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4577      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4578             if (lprn)
4579      &      write (iout,*) "m",m," k",k," bbthet",
4580      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4581      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4582      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4583      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4584           enddo
4585         enddo
4586         if (lprn)
4587      &  write(iout,*) "ethetai",ethetai
4588         do m=1,ntheterm3
4589           do k=2,ndouble
4590             do l=1,k-1
4591               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4592      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4593      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4594      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4595               ethetai=ethetai+sinkt(m)*aux
4596               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4597               dephii=dephii+l*sinkt(m)*(
4598      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4599      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4600      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4601      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4602               dephii1=dephii1+(k-l)*sinkt(m)*(
4603      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4604      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4605      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4606      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4607               if (lprn) then
4608               write (iout,*) "m",m," k",k," l",l," ffthet",
4609      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4610      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4611      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4612      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4613      &            " ethetai",ethetai
4614               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4615      &            cosph1ph2(k,l)*sinkt(m),
4616      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4617               endif
4618             enddo
4619           enddo
4620         enddo
4621 10      continue
4622         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4623      &   i,theta(i)*rad2deg,phii*rad2deg,
4624      &   phii1*rad2deg,ethetai
4625         etheta=etheta+ethetai
4626         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4627         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4628 c        gloc(nphi+i-2,icg)=wang*dethetai
4629         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4630       enddo
4631 C now constrains
4632       ethetacnstr=0.0d0
4633 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4634       do i=1,ntheta_constr
4635         itheta=itheta_constr(i)
4636         thetiii=theta(itheta)
4637         difi=pinorm(thetiii-theta_constr0(i))
4638         if (difi.gt.theta_drange(i)) then
4639           difi=difi-theta_drange(i)
4640           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4641           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4642      &    +for_thet_constr(i)*difi**3
4643         else if (difi.lt.-drange(i)) then
4644           difi=difi+drange(i)
4645           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4646           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4647      &    +for_thet_constr(i)*difi**3
4648         else
4649           difi=0.0
4650         endif
4651 C       if (energy_dec) then
4652 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4653 C     &    i,itheta,rad2deg*thetiii,
4654 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4655 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4656 C     &    gloc(itheta+nphi-2,icg)
4657 C        endif
4658       enddo
4659       return
4660       end
4661
4662 #endif
4663 #ifdef CRYST_SC
4664 c-----------------------------------------------------------------------------
4665       subroutine esc(escloc)
4666 C Calculate the local energy of a side chain and its derivatives in the
4667 C corresponding virtual-bond valence angles THETA and the spherical angles
4668 C ALPHA and OMEGA.
4669       implicit real*8 (a-h,o-z)
4670       include 'DIMENSIONS'
4671       include 'DIMENSIONS.ZSCOPT'
4672       include 'COMMON.GEO'
4673       include 'COMMON.LOCAL'
4674       include 'COMMON.VAR'
4675       include 'COMMON.INTERACT'
4676       include 'COMMON.DERIV'
4677       include 'COMMON.CHAIN'
4678       include 'COMMON.IOUNITS'
4679       include 'COMMON.NAMES'
4680       include 'COMMON.FFIELD'
4681       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4682      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4683       common /sccalc/ time11,time12,time112,theti,it,nlobit
4684       delta=0.02d0*pi
4685       escloc=0.0D0
4686 C      write (iout,*) 'ESC'
4687       do i=loc_start,loc_end
4688         it=itype(i)
4689         if (it.eq.ntyp1) cycle
4690         if (it.eq.10) goto 1
4691         nlobit=nlob(iabs(it))
4692 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4693 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4694         theti=theta(i+1)-pipol
4695         x(1)=dtan(theti)
4696         x(2)=alph(i)
4697         x(3)=omeg(i)
4698 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4699
4700         if (x(2).gt.pi-delta) then
4701           xtemp(1)=x(1)
4702           xtemp(2)=pi-delta
4703           xtemp(3)=x(3)
4704           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4705           xtemp(2)=pi
4706           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4707           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4708      &        escloci,dersc(2))
4709           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4710      &        ddersc0(1),dersc(1))
4711           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4712      &        ddersc0(3),dersc(3))
4713           xtemp(2)=pi-delta
4714           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4715           xtemp(2)=pi
4716           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4717           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4718      &            dersc0(2),esclocbi,dersc02)
4719           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4720      &            dersc12,dersc01)
4721           call splinthet(x(2),0.5d0*delta,ss,ssd)
4722           dersc0(1)=dersc01
4723           dersc0(2)=dersc02
4724           dersc0(3)=0.0d0
4725           do k=1,3
4726             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4727           enddo
4728           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4729           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4730      &             esclocbi,ss,ssd
4731           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4732 c         escloci=esclocbi
4733 c         write (iout,*) escloci
4734         else if (x(2).lt.delta) then
4735           xtemp(1)=x(1)
4736           xtemp(2)=delta
4737           xtemp(3)=x(3)
4738           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4739           xtemp(2)=0.0d0
4740           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4741           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4742      &        escloci,dersc(2))
4743           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4744      &        ddersc0(1),dersc(1))
4745           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4746      &        ddersc0(3),dersc(3))
4747           xtemp(2)=delta
4748           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4749           xtemp(2)=0.0d0
4750           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4751           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4752      &            dersc0(2),esclocbi,dersc02)
4753           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4754      &            dersc12,dersc01)
4755           dersc0(1)=dersc01
4756           dersc0(2)=dersc02
4757           dersc0(3)=0.0d0
4758           call splinthet(x(2),0.5d0*delta,ss,ssd)
4759           do k=1,3
4760             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4761           enddo
4762           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4763 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4764 c     &             esclocbi,ss,ssd
4765           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4766 C         write (iout,*) 'i=',i, escloci
4767         else
4768           call enesc(x,escloci,dersc,ddummy,.false.)
4769         endif
4770
4771         escloc=escloc+escloci
4772 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4773             write (iout,'(a6,i5,0pf7.3)')
4774      &     'escloc',i,escloci
4775
4776         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4777      &   wscloc*dersc(1)
4778         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4779         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4780     1   continue
4781       enddo
4782       return
4783       end
4784 C---------------------------------------------------------------------------
4785       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4786       implicit real*8 (a-h,o-z)
4787       include 'DIMENSIONS'
4788       include 'COMMON.GEO'
4789       include 'COMMON.LOCAL'
4790       include 'COMMON.IOUNITS'
4791       common /sccalc/ time11,time12,time112,theti,it,nlobit
4792       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4793       double precision contr(maxlob,-1:1)
4794       logical mixed
4795 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4796         escloc_i=0.0D0
4797         do j=1,3
4798           dersc(j)=0.0D0
4799           if (mixed) ddersc(j)=0.0d0
4800         enddo
4801         x3=x(3)
4802
4803 C Because of periodicity of the dependence of the SC energy in omega we have
4804 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4805 C To avoid underflows, first compute & store the exponents.
4806
4807         do iii=-1,1
4808
4809           x(3)=x3+iii*dwapi
4810
4811           do j=1,nlobit
4812             do k=1,3
4813               z(k)=x(k)-censc(k,j,it)
4814             enddo
4815             do k=1,3
4816               Axk=0.0D0
4817               do l=1,3
4818                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4819               enddo
4820               Ax(k,j,iii)=Axk
4821             enddo
4822             expfac=0.0D0
4823             do k=1,3
4824               expfac=expfac+Ax(k,j,iii)*z(k)
4825             enddo
4826             contr(j,iii)=expfac
4827           enddo ! j
4828
4829         enddo ! iii
4830
4831         x(3)=x3
4832 C As in the case of ebend, we want to avoid underflows in exponentiation and
4833 C subsequent NaNs and INFs in energy calculation.
4834 C Find the largest exponent
4835         emin=contr(1,-1)
4836         do iii=-1,1
4837           do j=1,nlobit
4838             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4839           enddo
4840         enddo
4841         emin=0.5D0*emin
4842 cd      print *,'it=',it,' emin=',emin
4843
4844 C Compute the contribution to SC energy and derivatives
4845         do iii=-1,1
4846
4847           do j=1,nlobit
4848             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4849 cd          print *,'j=',j,' expfac=',expfac
4850             escloc_i=escloc_i+expfac
4851             do k=1,3
4852               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4853             enddo
4854             if (mixed) then
4855               do k=1,3,2
4856                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4857      &            +gaussc(k,2,j,it))*expfac
4858               enddo
4859             endif
4860           enddo
4861
4862         enddo ! iii
4863
4864         dersc(1)=dersc(1)/cos(theti)**2
4865         ddersc(1)=ddersc(1)/cos(theti)**2
4866         ddersc(3)=ddersc(3)
4867
4868         escloci=-(dlog(escloc_i)-emin)
4869         do j=1,3
4870           dersc(j)=dersc(j)/escloc_i
4871         enddo
4872         if (mixed) then
4873           do j=1,3,2
4874             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4875           enddo
4876         endif
4877       return
4878       end
4879 C------------------------------------------------------------------------------
4880       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4881       implicit real*8 (a-h,o-z)
4882       include 'DIMENSIONS'
4883       include 'COMMON.GEO'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.IOUNITS'
4886       common /sccalc/ time11,time12,time112,theti,it,nlobit
4887       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4888       double precision contr(maxlob)
4889       logical mixed
4890
4891       escloc_i=0.0D0
4892
4893       do j=1,3
4894         dersc(j)=0.0D0
4895       enddo
4896
4897       do j=1,nlobit
4898         do k=1,2
4899           z(k)=x(k)-censc(k,j,it)
4900         enddo
4901         z(3)=dwapi
4902         do k=1,3
4903           Axk=0.0D0
4904           do l=1,3
4905             Axk=Axk+gaussc(l,k,j,it)*z(l)
4906           enddo
4907           Ax(k,j)=Axk
4908         enddo
4909         expfac=0.0D0
4910         do k=1,3
4911           expfac=expfac+Ax(k,j)*z(k)
4912         enddo
4913         contr(j)=expfac
4914       enddo ! j
4915
4916 C As in the case of ebend, we want to avoid underflows in exponentiation and
4917 C subsequent NaNs and INFs in energy calculation.
4918 C Find the largest exponent
4919       emin=contr(1)
4920       do j=1,nlobit
4921         if (emin.gt.contr(j)) emin=contr(j)
4922       enddo
4923       emin=0.5D0*emin
4924
4925 C Compute the contribution to SC energy and derivatives
4926
4927       dersc12=0.0d0
4928       do j=1,nlobit
4929         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4930         escloc_i=escloc_i+expfac
4931         do k=1,2
4932           dersc(k)=dersc(k)+Ax(k,j)*expfac
4933         enddo
4934         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4935      &            +gaussc(1,2,j,it))*expfac
4936         dersc(3)=0.0d0
4937       enddo
4938
4939       dersc(1)=dersc(1)/cos(theti)**2
4940       dersc12=dersc12/cos(theti)**2
4941       escloci=-(dlog(escloc_i)-emin)
4942       do j=1,2
4943         dersc(j)=dersc(j)/escloc_i
4944       enddo
4945       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4946       return
4947       end
4948 #else
4949 c----------------------------------------------------------------------------------
4950       subroutine esc(escloc)
4951 C Calculate the local energy of a side chain and its derivatives in the
4952 C corresponding virtual-bond valence angles THETA and the spherical angles
4953 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4954 C added by Urszula Kozlowska. 07/11/2007
4955 C
4956       implicit real*8 (a-h,o-z)
4957       include 'DIMENSIONS'
4958       include 'DIMENSIONS.ZSCOPT'
4959       include 'DIMENSIONS.FREE'
4960       include 'COMMON.GEO'
4961       include 'COMMON.LOCAL'
4962       include 'COMMON.VAR'
4963       include 'COMMON.SCROT'
4964       include 'COMMON.INTERACT'
4965       include 'COMMON.DERIV'
4966       include 'COMMON.CHAIN'
4967       include 'COMMON.IOUNITS'
4968       include 'COMMON.NAMES'
4969       include 'COMMON.FFIELD'
4970       include 'COMMON.CONTROL'
4971       include 'COMMON.VECTORS'
4972       double precision x_prime(3),y_prime(3),z_prime(3)
4973      &    , sumene,dsc_i,dp2_i,x(65),
4974      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4975      &    de_dxx,de_dyy,de_dzz,de_dt
4976       double precision s1_t,s1_6_t,s2_t,s2_6_t
4977       double precision
4978      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4979      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4980      & dt_dCi(3),dt_dCi1(3)
4981       common /sccalc/ time11,time12,time112,theti,it,nlobit
4982       delta=0.02d0*pi
4983       escloc=0.0D0
4984       do i=loc_start,loc_end
4985         if (itype(i).eq.ntyp1) cycle
4986         costtab(i+1) =dcos(theta(i+1))
4987         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4988         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4989         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4990         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4991         cosfac=dsqrt(cosfac2)
4992         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4993         sinfac=dsqrt(sinfac2)
4994         it=iabs(itype(i))
4995         if (it.eq.10) goto 1
4996 c
4997 C  Compute the axes of tghe local cartesian coordinates system; store in
4998 c   x_prime, y_prime and z_prime
4999 c
5000         do j=1,3
5001           x_prime(j) = 0.00
5002           y_prime(j) = 0.00
5003           z_prime(j) = 0.00
5004         enddo
5005 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5006 C     &   dc_norm(3,i+nres)
5007         do j = 1,3
5008           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5009           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5010         enddo
5011         do j = 1,3
5012           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5013         enddo
5014 c       write (2,*) "i",i
5015 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5016 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5017 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5018 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5019 c      & " xy",scalar(x_prime(1),y_prime(1)),
5020 c      & " xz",scalar(x_prime(1),z_prime(1)),
5021 c      & " yy",scalar(y_prime(1),y_prime(1)),
5022 c      & " yz",scalar(y_prime(1),z_prime(1)),
5023 c      & " zz",scalar(z_prime(1),z_prime(1))
5024 c
5025 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5026 C to local coordinate system. Store in xx, yy, zz.
5027 c
5028         xx=0.0d0
5029         yy=0.0d0
5030         zz=0.0d0
5031         do j = 1,3
5032           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5033           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5034           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5035         enddo
5036
5037         xxtab(i)=xx
5038         yytab(i)=yy
5039         zztab(i)=zz
5040 C
5041 C Compute the energy of the ith side cbain
5042 C
5043 c        write (2,*) "xx",xx," yy",yy," zz",zz
5044         it=iabs(itype(i))
5045         do j = 1,65
5046           x(j) = sc_parmin(j,it)
5047         enddo
5048 #ifdef CHECK_COORD
5049 Cc diagnostics - remove later
5050         xx1 = dcos(alph(2))
5051         yy1 = dsin(alph(2))*dcos(omeg(2))
5052         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5053         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5054      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5055      &    xx1,yy1,zz1
5056 C,"  --- ", xx_w,yy_w,zz_w
5057 c end diagnostics
5058 #endif
5059         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5060      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5061      &   + x(10)*yy*zz
5062         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5063      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5064      & + x(20)*yy*zz
5065         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5066      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5067      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5068      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5069      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5070      &  +x(40)*xx*yy*zz
5071         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5072      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5073      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5074      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5075      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5076      &  +x(60)*xx*yy*zz
5077         dsc_i   = 0.743d0+x(61)
5078         dp2_i   = 1.9d0+x(62)
5079         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5080      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5081         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5082      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5083         s1=(1+x(63))/(0.1d0 + dscp1)
5084         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5085         s2=(1+x(65))/(0.1d0 + dscp2)
5086         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5087         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5088      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5089 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5090 c     &   sumene4,
5091 c     &   dscp1,dscp2,sumene
5092 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5093         escloc = escloc + sumene
5094 c        write (2,*) "escloc",escloc
5095 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5096 c     &  zz,xx,yy
5097         if (.not. calc_grad) goto 1
5098 #ifdef DEBUG
5099 C
5100 C This section to check the numerical derivatives of the energy of ith side
5101 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5102 C #define DEBUG in the code to turn it on.
5103 C
5104         write (2,*) "sumene               =",sumene
5105         aincr=1.0d-7
5106         xxsave=xx
5107         xx=xx+aincr
5108         write (2,*) xx,yy,zz
5109         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5110         de_dxx_num=(sumenep-sumene)/aincr
5111         xx=xxsave
5112         write (2,*) "xx+ sumene from enesc=",sumenep
5113         yysave=yy
5114         yy=yy+aincr
5115         write (2,*) xx,yy,zz
5116         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5117         de_dyy_num=(sumenep-sumene)/aincr
5118         yy=yysave
5119         write (2,*) "yy+ sumene from enesc=",sumenep
5120         zzsave=zz
5121         zz=zz+aincr
5122         write (2,*) xx,yy,zz
5123         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5124         de_dzz_num=(sumenep-sumene)/aincr
5125         zz=zzsave
5126         write (2,*) "zz+ sumene from enesc=",sumenep
5127         costsave=cost2tab(i+1)
5128         sintsave=sint2tab(i+1)
5129         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5130         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5131         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5132         de_dt_num=(sumenep-sumene)/aincr
5133         write (2,*) " t+ sumene from enesc=",sumenep
5134         cost2tab(i+1)=costsave
5135         sint2tab(i+1)=sintsave
5136 C End of diagnostics section.
5137 #endif
5138 C
5139 C Compute the gradient of esc
5140 C
5141         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5142         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5143         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5144         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5145         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5146         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5147         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5148         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5149         pom1=(sumene3*sint2tab(i+1)+sumene1)
5150      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5151         pom2=(sumene4*cost2tab(i+1)+sumene2)
5152      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5153         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5154         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5155      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5156      &  +x(40)*yy*zz
5157         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5158         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5159      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5160      &  +x(60)*yy*zz
5161         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5162      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5163      &        +(pom1+pom2)*pom_dx
5164 #ifdef DEBUG
5165         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5166 #endif
5167 C
5168         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5169         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5170      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5171      &  +x(40)*xx*zz
5172         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5173         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5174      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5175      &  +x(59)*zz**2 +x(60)*xx*zz
5176         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5177      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5178      &        +(pom1-pom2)*pom_dy
5179 #ifdef DEBUG
5180         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5181 #endif
5182 C
5183         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5184      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5185      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5186      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5187      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5188      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5189      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5190      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5191 #ifdef DEBUG
5192         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5193 #endif
5194 C
5195         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5196      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5197      &  +pom1*pom_dt1+pom2*pom_dt2
5198 #ifdef DEBUG
5199         write(2,*), "de_dt = ", de_dt,de_dt_num
5200 #endif
5201 c
5202 C
5203        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5204        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5205        cosfac2xx=cosfac2*xx
5206        sinfac2yy=sinfac2*yy
5207        do k = 1,3
5208          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5209      &      vbld_inv(i+1)
5210          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5211      &      vbld_inv(i)
5212          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5213          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5214 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5215 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5216 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5217 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5218          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5219          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5220          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5221          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5222          dZZ_Ci1(k)=0.0d0
5223          dZZ_Ci(k)=0.0d0
5224          do j=1,3
5225            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5226      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5227            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5228      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5229          enddo
5230
5231          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5232          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5233          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5234 c
5235          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5236          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5237        enddo
5238
5239        do k=1,3
5240          dXX_Ctab(k,i)=dXX_Ci(k)
5241          dXX_C1tab(k,i)=dXX_Ci1(k)
5242          dYY_Ctab(k,i)=dYY_Ci(k)
5243          dYY_C1tab(k,i)=dYY_Ci1(k)
5244          dZZ_Ctab(k,i)=dZZ_Ci(k)
5245          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5246          dXX_XYZtab(k,i)=dXX_XYZ(k)
5247          dYY_XYZtab(k,i)=dYY_XYZ(k)
5248          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5249        enddo
5250
5251        do k = 1,3
5252 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5253 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5254 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5255 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5256 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5257 c     &    dt_dci(k)
5258 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5259 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5260          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5261      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5262          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5263      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5264          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5265      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5266        enddo
5267 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5268 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5269
5270 C to check gradient call subroutine check_grad
5271
5272     1 continue
5273       enddo
5274       return
5275       end
5276 #endif
5277 c------------------------------------------------------------------------------
5278       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5279 C
5280 C This procedure calculates two-body contact function g(rij) and its derivative:
5281 C
5282 C           eps0ij                                     !       x < -1
5283 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5284 C            0                                         !       x > 1
5285 C
5286 C where x=(rij-r0ij)/delta
5287 C
5288 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5289 C
5290       implicit none
5291       double precision rij,r0ij,eps0ij,fcont,fprimcont
5292       double precision x,x2,x4,delta
5293 c     delta=0.02D0*r0ij
5294 c      delta=0.2D0*r0ij
5295       x=(rij-r0ij)/delta
5296       if (x.lt.-1.0D0) then
5297         fcont=eps0ij
5298         fprimcont=0.0D0
5299       else if (x.le.1.0D0) then
5300         x2=x*x
5301         x4=x2*x2
5302         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5303         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5304       else
5305         fcont=0.0D0
5306         fprimcont=0.0D0
5307       endif
5308       return
5309       end
5310 c------------------------------------------------------------------------------
5311       subroutine splinthet(theti,delta,ss,ssder)
5312       implicit real*8 (a-h,o-z)
5313       include 'DIMENSIONS'
5314       include 'DIMENSIONS.ZSCOPT'
5315       include 'COMMON.VAR'
5316       include 'COMMON.GEO'
5317       thetup=pi-delta
5318       thetlow=delta
5319       if (theti.gt.pipol) then
5320         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5321       else
5322         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5323         ssder=-ssder
5324       endif
5325       return
5326       end
5327 c------------------------------------------------------------------------------
5328       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5329       implicit none
5330       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5331       double precision ksi,ksi2,ksi3,a1,a2,a3
5332       a1=fprim0*delta/(f1-f0)
5333       a2=3.0d0-2.0d0*a1
5334       a3=a1-2.0d0
5335       ksi=(x-x0)/delta
5336       ksi2=ksi*ksi
5337       ksi3=ksi2*ksi
5338       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5339       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5340       return
5341       end
5342 c------------------------------------------------------------------------------
5343       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5344       implicit none
5345       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5346       double precision ksi,ksi2,ksi3,a1,a2,a3
5347       ksi=(x-x0)/delta
5348       ksi2=ksi*ksi
5349       ksi3=ksi2*ksi
5350       a1=fprim0x*delta
5351       a2=3*(f1x-f0x)-2*fprim0x*delta
5352       a3=fprim0x*delta-2*(f1x-f0x)
5353       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5354       return
5355       end
5356 C-----------------------------------------------------------------------------
5357 #ifdef CRYST_TOR
5358 C-----------------------------------------------------------------------------
5359       subroutine etor(etors,edihcnstr,fact)
5360       implicit real*8 (a-h,o-z)
5361       include 'DIMENSIONS'
5362       include 'DIMENSIONS.ZSCOPT'
5363       include 'COMMON.VAR'
5364       include 'COMMON.GEO'
5365       include 'COMMON.LOCAL'
5366       include 'COMMON.TORSION'
5367       include 'COMMON.INTERACT'
5368       include 'COMMON.DERIV'
5369       include 'COMMON.CHAIN'
5370       include 'COMMON.NAMES'
5371       include 'COMMON.IOUNITS'
5372       include 'COMMON.FFIELD'
5373       include 'COMMON.TORCNSTR'
5374       logical lprn
5375 C Set lprn=.true. for debugging
5376       lprn=.false.
5377 c      lprn=.true.
5378       etors=0.0D0
5379       do i=iphi_start,iphi_end
5380         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5381      &      .or. itype(i).eq.ntyp1) cycle
5382         itori=itortyp(itype(i-2))
5383         itori1=itortyp(itype(i-1))
5384         phii=phi(i)
5385         gloci=0.0D0
5386 C Proline-Proline pair is a special case...
5387         if (itori.eq.3 .and. itori1.eq.3) then
5388           if (phii.gt.-dwapi3) then
5389             cosphi=dcos(3*phii)
5390             fac=1.0D0/(1.0D0-cosphi)
5391             etorsi=v1(1,3,3)*fac
5392             etorsi=etorsi+etorsi
5393             etors=etors+etorsi-v1(1,3,3)
5394             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5395           endif
5396           do j=1,3
5397             v1ij=v1(j+1,itori,itori1)
5398             v2ij=v2(j+1,itori,itori1)
5399             cosphi=dcos(j*phii)
5400             sinphi=dsin(j*phii)
5401             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5402             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5403           enddo
5404         else
5405           do j=1,nterm_old
5406             v1ij=v1(j,itori,itori1)
5407             v2ij=v2(j,itori,itori1)
5408             cosphi=dcos(j*phii)
5409             sinphi=dsin(j*phii)
5410             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5411             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5412           enddo
5413         endif
5414         if (lprn)
5415      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5416      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5417      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5418         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5419 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5420       enddo
5421 ! 6/20/98 - dihedral angle constraints
5422       edihcnstr=0.0d0
5423       do i=1,ndih_constr
5424         itori=idih_constr(i)
5425         phii=phi(itori)
5426         difi=phii-phi0(i)
5427         if (difi.gt.drange(i)) then
5428           difi=difi-drange(i)
5429           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5430           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5431         else if (difi.lt.-drange(i)) then
5432           difi=difi+drange(i)
5433           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5434           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5435         endif
5436 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5437 C     &    i,itori,rad2deg*phii,
5438 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5439       enddo
5440 !      write (iout,*) 'edihcnstr',edihcnstr
5441       return
5442       end
5443 c------------------------------------------------------------------------------
5444 #else
5445       subroutine etor(etors,edihcnstr,fact)
5446       implicit real*8 (a-h,o-z)
5447       include 'DIMENSIONS'
5448       include 'DIMENSIONS.ZSCOPT'
5449       include 'COMMON.VAR'
5450       include 'COMMON.GEO'
5451       include 'COMMON.LOCAL'
5452       include 'COMMON.TORSION'
5453       include 'COMMON.INTERACT'
5454       include 'COMMON.DERIV'
5455       include 'COMMON.CHAIN'
5456       include 'COMMON.NAMES'
5457       include 'COMMON.IOUNITS'
5458       include 'COMMON.FFIELD'
5459       include 'COMMON.TORCNSTR'
5460       logical lprn
5461 C Set lprn=.true. for debugging
5462       lprn=.false.
5463 c      lprn=.true.
5464       etors=0.0D0
5465       do i=iphi_start,iphi_end
5466         if (i.le.2) cycle
5467         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5468      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5469 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5470 C     &       .or. itype(i).eq.ntyp1) cycle
5471         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5472          if (iabs(itype(i)).eq.20) then
5473          iblock=2
5474          else
5475          iblock=1
5476          endif
5477         itori=itortyp(itype(i-2))
5478         itori1=itortyp(itype(i-1))
5479         phii=phi(i)
5480         gloci=0.0D0
5481 C Regular cosine and sine terms
5482         do j=1,nterm(itori,itori1,iblock)
5483           v1ij=v1(j,itori,itori1,iblock)
5484           v2ij=v2(j,itori,itori1,iblock)
5485           cosphi=dcos(j*phii)
5486           sinphi=dsin(j*phii)
5487           etors=etors+v1ij*cosphi+v2ij*sinphi
5488           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5489         enddo
5490 C Lorentz terms
5491 C                         v1
5492 C  E = SUM ----------------------------------- - v1
5493 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5494 C
5495         cosphi=dcos(0.5d0*phii)
5496         sinphi=dsin(0.5d0*phii)
5497         do j=1,nlor(itori,itori1,iblock)
5498           vl1ij=vlor1(j,itori,itori1)
5499           vl2ij=vlor2(j,itori,itori1)
5500           vl3ij=vlor3(j,itori,itori1)
5501           pom=vl2ij*cosphi+vl3ij*sinphi
5502           pom1=1.0d0/(pom*pom+1.0d0)
5503           etors=etors+vl1ij*pom1
5504 c          if (energy_dec) etors_ii=etors_ii+
5505 c     &                vl1ij*pom1
5506           pom=-pom*pom1*pom1
5507           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5508         enddo
5509 C Subtract the constant term
5510         etors=etors-v0(itori,itori1,iblock)
5511         if (lprn)
5512      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5513      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5514      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5515         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5516 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5517  1215   continue
5518       enddo
5519 ! 6/20/98 - dihedral angle constraints
5520       edihcnstr=0.0d0
5521       do i=1,ndih_constr
5522         itori=idih_constr(i)
5523         phii=phi(itori)
5524         difi=pinorm(phii-phi0(i))
5525         edihi=0.0d0
5526         if (difi.gt.drange(i)) then
5527           difi=difi-drange(i)
5528           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5529           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5530           edihi=0.25d0*ftors(i)*difi**4
5531         else if (difi.lt.-drange(i)) then
5532           difi=difi+drange(i)
5533           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5534           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5535           edihi=0.25d0*ftors(i)*difi**4
5536         else
5537           difi=0.0d0
5538         endif
5539         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5540      &    i,itori,rad2deg*phii,
5541      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5542 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5543 c     &    drange(i),edihi
5544 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5545 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5546       enddo
5547 !      write (iout,*) 'edihcnstr',edihcnstr
5548       return
5549       end
5550 c----------------------------------------------------------------------------
5551       subroutine etor_d(etors_d,fact2)
5552 C 6/23/01 Compute double torsional energy
5553       implicit real*8 (a-h,o-z)
5554       include 'DIMENSIONS'
5555       include 'DIMENSIONS.ZSCOPT'
5556       include 'COMMON.VAR'
5557       include 'COMMON.GEO'
5558       include 'COMMON.LOCAL'
5559       include 'COMMON.TORSION'
5560       include 'COMMON.INTERACT'
5561       include 'COMMON.DERIV'
5562       include 'COMMON.CHAIN'
5563       include 'COMMON.NAMES'
5564       include 'COMMON.IOUNITS'
5565       include 'COMMON.FFIELD'
5566       include 'COMMON.TORCNSTR'
5567       logical lprn
5568 C Set lprn=.true. for debugging
5569       lprn=.false.
5570 c     lprn=.true.
5571       etors_d=0.0D0
5572       do i=iphi_start,iphi_end-1
5573         if (i.le.3) cycle
5574 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5575 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5576          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5577      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5578      &  (itype(i+1).eq.ntyp1)) cycle
5579         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5580      &     goto 1215
5581         itori=itortyp(itype(i-2))
5582         itori1=itortyp(itype(i-1))
5583         itori2=itortyp(itype(i))
5584         phii=phi(i)
5585         phii1=phi(i+1)
5586         gloci1=0.0D0
5587         gloci2=0.0D0
5588         iblock=1
5589         if (iabs(itype(i+1)).eq.20) iblock=2
5590 C Regular cosine and sine terms
5591         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5592           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5593           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5594           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5595           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5596           cosphi1=dcos(j*phii)
5597           sinphi1=dsin(j*phii)
5598           cosphi2=dcos(j*phii1)
5599           sinphi2=dsin(j*phii1)
5600           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5601      &     v2cij*cosphi2+v2sij*sinphi2
5602           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5603           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5604         enddo
5605         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5606           do l=1,k-1
5607             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5608             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5609             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5610             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5611             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5612             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5613             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5614             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5615             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5616      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5617             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5618      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5619             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5620      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5621           enddo
5622         enddo
5623         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5624         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5625  1215   continue
5626       enddo
5627       return
5628       end
5629 #endif
5630 c------------------------------------------------------------------------------
5631       subroutine eback_sc_corr(esccor)
5632 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5633 c        conformational states; temporarily implemented as differences
5634 c        between UNRES torsional potentials (dependent on three types of
5635 c        residues) and the torsional potentials dependent on all 20 types
5636 c        of residues computed from AM1 energy surfaces of terminally-blocked
5637 c        amino-acid residues.
5638       implicit real*8 (a-h,o-z)
5639       include 'DIMENSIONS'
5640       include 'DIMENSIONS.ZSCOPT'
5641       include 'DIMENSIONS.FREE'
5642       include 'COMMON.VAR'
5643       include 'COMMON.GEO'
5644       include 'COMMON.LOCAL'
5645       include 'COMMON.TORSION'
5646       include 'COMMON.SCCOR'
5647       include 'COMMON.INTERACT'
5648       include 'COMMON.DERIV'
5649       include 'COMMON.CHAIN'
5650       include 'COMMON.NAMES'
5651       include 'COMMON.IOUNITS'
5652       include 'COMMON.FFIELD'
5653       include 'COMMON.CONTROL'
5654       logical lprn
5655 C Set lprn=.true. for debugging
5656       lprn=.false.
5657 c      lprn=.true.
5658 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5659       esccor=0.0D0
5660       do i=itau_start,itau_end
5661         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5662         esccor_ii=0.0D0
5663         isccori=isccortyp(itype(i-2))
5664         isccori1=isccortyp(itype(i-1))
5665         phii=phi(i)
5666         do intertyp=1,3 !intertyp
5667 cc Added 09 May 2012 (Adasko)
5668 cc  Intertyp means interaction type of backbone mainchain correlation:
5669 c   1 = SC...Ca...Ca...Ca
5670 c   2 = Ca...Ca...Ca...SC
5671 c   3 = SC...Ca...Ca...SCi
5672         gloci=0.0D0
5673         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5674      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5675      &      (itype(i-1).eq.ntyp1)))
5676      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5677      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5678      &     .or.(itype(i).eq.ntyp1)))
5679      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5680      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5681      &      (itype(i-3).eq.ntyp1)))) cycle
5682         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5683         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5684      & cycle
5685        do j=1,nterm_sccor(isccori,isccori1)
5686           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5687           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5688           cosphi=dcos(j*tauangle(intertyp,i))
5689           sinphi=dsin(j*tauangle(intertyp,i))
5690            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5691            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5692          enddo
5693 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5694 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5695 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5696         if (lprn)
5697      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5698      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5699      &  (v1sccor(j,1,itori,itori1),j=1,6)
5700      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5701 c        gsccor_loc(i-3)=gloci
5702        enddo !intertyp
5703       enddo
5704       return
5705       end
5706 c------------------------------------------------------------------------------
5707       subroutine multibody(ecorr)
5708 C This subroutine calculates multi-body contributions to energy following
5709 C the idea of Skolnick et al. If side chains I and J make a contact and
5710 C at the same time side chains I+1 and J+1 make a contact, an extra
5711 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5712       implicit real*8 (a-h,o-z)
5713       include 'DIMENSIONS'
5714       include 'COMMON.IOUNITS'
5715       include 'COMMON.DERIV'
5716       include 'COMMON.INTERACT'
5717       include 'COMMON.CONTACTS'
5718       double precision gx(3),gx1(3)
5719       logical lprn
5720
5721 C Set lprn=.true. for debugging
5722       lprn=.false.
5723
5724       if (lprn) then
5725         write (iout,'(a)') 'Contact function values:'
5726         do i=nnt,nct-2
5727           write (iout,'(i2,20(1x,i2,f10.5))')
5728      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5729         enddo
5730       endif
5731       ecorr=0.0D0
5732       do i=nnt,nct
5733         do j=1,3
5734           gradcorr(j,i)=0.0D0
5735           gradxorr(j,i)=0.0D0
5736         enddo
5737       enddo
5738       do i=nnt,nct-2
5739
5740         DO ISHIFT = 3,4
5741
5742         i1=i+ishift
5743         num_conti=num_cont(i)
5744         num_conti1=num_cont(i1)
5745         do jj=1,num_conti
5746           j=jcont(jj,i)
5747           do kk=1,num_conti1
5748             j1=jcont(kk,i1)
5749             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5750 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5751 cd   &                   ' ishift=',ishift
5752 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5753 C The system gains extra energy.
5754               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5755             endif   ! j1==j+-ishift
5756           enddo     ! kk
5757         enddo       ! jj
5758
5759         ENDDO ! ISHIFT
5760
5761       enddo         ! i
5762       return
5763       end
5764 c------------------------------------------------------------------------------
5765       double precision function esccorr(i,j,k,l,jj,kk)
5766       implicit real*8 (a-h,o-z)
5767       include 'DIMENSIONS'
5768       include 'COMMON.IOUNITS'
5769       include 'COMMON.DERIV'
5770       include 'COMMON.INTERACT'
5771       include 'COMMON.CONTACTS'
5772       double precision gx(3),gx1(3)
5773       logical lprn
5774       lprn=.false.
5775       eij=facont(jj,i)
5776       ekl=facont(kk,k)
5777 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5778 C Calculate the multi-body contribution to energy.
5779 C Calculate multi-body contributions to the gradient.
5780 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5781 cd   & k,l,(gacont(m,kk,k),m=1,3)
5782       do m=1,3
5783         gx(m) =ekl*gacont(m,jj,i)
5784         gx1(m)=eij*gacont(m,kk,k)
5785         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5786         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5787         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5788         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5789       enddo
5790       do m=i,j-1
5791         do ll=1,3
5792           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5793         enddo
5794       enddo
5795       do m=k,l-1
5796         do ll=1,3
5797           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5798         enddo
5799       enddo
5800       esccorr=-eij*ekl
5801       return
5802       end
5803 c------------------------------------------------------------------------------
5804 #ifdef MPL
5805       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       integer dimen1,dimen2,atom,indx
5809       double precision buffer(dimen1,dimen2)
5810       double precision zapas
5811       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5812      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5813      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5814       num_kont=num_cont_hb(atom)
5815       do i=1,num_kont
5816         do k=1,7
5817           do j=1,3
5818             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5819           enddo ! j
5820         enddo ! k
5821         buffer(i,indx+22)=facont_hb(i,atom)
5822         buffer(i,indx+23)=ees0p(i,atom)
5823         buffer(i,indx+24)=ees0m(i,atom)
5824         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5825       enddo ! i
5826       buffer(1,indx+26)=dfloat(num_kont)
5827       return
5828       end
5829 c------------------------------------------------------------------------------
5830       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5831       implicit real*8 (a-h,o-z)
5832       include 'DIMENSIONS'
5833       integer dimen1,dimen2,atom,indx
5834       double precision buffer(dimen1,dimen2)
5835       double precision zapas
5836       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5837      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5838      &         ees0m(ntyp,maxres),
5839      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5840       num_kont=buffer(1,indx+26)
5841       num_kont_old=num_cont_hb(atom)
5842       num_cont_hb(atom)=num_kont+num_kont_old
5843       do i=1,num_kont
5844         ii=i+num_kont_old
5845         do k=1,7
5846           do j=1,3
5847             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5848           enddo ! j
5849         enddo ! k
5850         facont_hb(ii,atom)=buffer(i,indx+22)
5851         ees0p(ii,atom)=buffer(i,indx+23)
5852         ees0m(ii,atom)=buffer(i,indx+24)
5853         jcont_hb(ii,atom)=buffer(i,indx+25)
5854       enddo ! i
5855       return
5856       end
5857 c------------------------------------------------------------------------------
5858 #endif
5859       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5860 C This subroutine calculates multi-body contributions to hydrogen-bonding
5861       implicit real*8 (a-h,o-z)
5862       include 'DIMENSIONS'
5863       include 'DIMENSIONS.ZSCOPT'
5864       include 'COMMON.IOUNITS'
5865 #ifdef MPL
5866       include 'COMMON.INFO'
5867 #endif
5868       include 'COMMON.FFIELD'
5869       include 'COMMON.DERIV'
5870       include 'COMMON.INTERACT'
5871       include 'COMMON.CONTACTS'
5872 #ifdef MPL
5873       parameter (max_cont=maxconts)
5874       parameter (max_dim=2*(8*3+2))
5875       parameter (msglen1=max_cont*max_dim*4)
5876       parameter (msglen2=2*msglen1)
5877       integer source,CorrelType,CorrelID,Error
5878       double precision buffer(max_cont,max_dim)
5879 #endif
5880       double precision gx(3),gx1(3)
5881       logical lprn,ldone
5882
5883 C Set lprn=.true. for debugging
5884       lprn=.false.
5885 #ifdef MPL
5886       n_corr=0
5887       n_corr1=0
5888       if (fgProcs.le.1) goto 30
5889       if (lprn) then
5890         write (iout,'(a)') 'Contact function values:'
5891         do i=nnt,nct-2
5892           write (iout,'(2i3,50(1x,i2,f5.2))')
5893      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5894      &    j=1,num_cont_hb(i))
5895         enddo
5896       endif
5897 C Caution! Following code assumes that electrostatic interactions concerning
5898 C a given atom are split among at most two processors!
5899       CorrelType=477
5900       CorrelID=MyID+1
5901       ldone=.false.
5902       do i=1,max_cont
5903         do j=1,max_dim
5904           buffer(i,j)=0.0D0
5905         enddo
5906       enddo
5907       mm=mod(MyRank,2)
5908 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5909       if (mm) 20,20,10
5910    10 continue
5911 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5912       if (MyRank.gt.0) then
5913 C Send correlation contributions to the preceding processor
5914         msglen=msglen1
5915         nn=num_cont_hb(iatel_s)
5916         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5917 cd      write (iout,*) 'The BUFFER array:'
5918 cd      do i=1,nn
5919 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5920 cd      enddo
5921         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5922           msglen=msglen2
5923             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5924 C Clear the contacts of the atom passed to the neighboring processor
5925         nn=num_cont_hb(iatel_s+1)
5926 cd      do i=1,nn
5927 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5928 cd      enddo
5929             num_cont_hb(iatel_s)=0
5930         endif
5931 cd      write (iout,*) 'Processor ',MyID,MyRank,
5932 cd   & ' is sending correlation contribution to processor',MyID-1,
5933 cd   & ' msglen=',msglen
5934 cd      write (*,*) 'Processor ',MyID,MyRank,
5935 cd   & ' is sending correlation contribution to processor',MyID-1,
5936 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5937         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5938 cd      write (iout,*) 'Processor ',MyID,
5939 cd   & ' has sent correlation contribution to processor',MyID-1,
5940 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5941 cd      write (*,*) 'Processor ',MyID,
5942 cd   & ' has sent correlation contribution to processor',MyID-1,
5943 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5944         msglen=msglen1
5945       endif ! (MyRank.gt.0)
5946       if (ldone) goto 30
5947       ldone=.true.
5948    20 continue
5949 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5950       if (MyRank.lt.fgProcs-1) then
5951 C Receive correlation contributions from the next processor
5952         msglen=msglen1
5953         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5954 cd      write (iout,*) 'Processor',MyID,
5955 cd   & ' is receiving correlation contribution from processor',MyID+1,
5956 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5957 cd      write (*,*) 'Processor',MyID,
5958 cd   & ' is receiving correlation contribution from processor',MyID+1,
5959 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5960         nbytes=-1
5961         do while (nbytes.le.0)
5962           call mp_probe(MyID+1,CorrelType,nbytes)
5963         enddo
5964 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5965         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5966 cd      write (iout,*) 'Processor',MyID,
5967 cd   & ' has received correlation contribution from processor',MyID+1,
5968 cd   & ' msglen=',msglen,' nbytes=',nbytes
5969 cd      write (iout,*) 'The received BUFFER array:'
5970 cd      do i=1,max_cont
5971 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5972 cd      enddo
5973         if (msglen.eq.msglen1) then
5974           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5975         else if (msglen.eq.msglen2)  then
5976           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5977           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5978         else
5979           write (iout,*)
5980      & 'ERROR!!!! message length changed while processing correlations.'
5981           write (*,*)
5982      & 'ERROR!!!! message length changed while processing correlations.'
5983           call mp_stopall(Error)
5984         endif ! msglen.eq.msglen1
5985       endif ! MyRank.lt.fgProcs-1
5986       if (ldone) goto 30
5987       ldone=.true.
5988       goto 10
5989    30 continue
5990 #endif
5991       if (lprn) then
5992         write (iout,'(a)') 'Contact function values:'
5993         do i=nnt,nct-2
5994           write (iout,'(2i3,50(1x,i2,f5.2))')
5995      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5996      &    j=1,num_cont_hb(i))
5997         enddo
5998       endif
5999       ecorr=0.0D0
6000 C Remove the loop below after debugging !!!
6001       do i=nnt,nct
6002         do j=1,3
6003           gradcorr(j,i)=0.0D0
6004           gradxorr(j,i)=0.0D0
6005         enddo
6006       enddo
6007 C Calculate the local-electrostatic correlation terms
6008       do i=iatel_s,iatel_e+1
6009         i1=i+1
6010         num_conti=num_cont_hb(i)
6011         num_conti1=num_cont_hb(i+1)
6012         do jj=1,num_conti
6013           j=jcont_hb(jj,i)
6014           do kk=1,num_conti1
6015             j1=jcont_hb(kk,i1)
6016 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6017 c     &         ' jj=',jj,' kk=',kk
6018             if (j1.eq.j+1 .or. j1.eq.j-1) then
6019 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6020 C The system gains extra energy.
6021               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6022               n_corr=n_corr+1
6023             else if (j1.eq.j) then
6024 C Contacts I-J and I-(J+1) occur simultaneously.
6025 C The system loses extra energy.
6026 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6027             endif
6028           enddo ! kk
6029           do kk=1,num_conti
6030             j1=jcont_hb(kk,i)
6031 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6032 c    &         ' jj=',jj,' kk=',kk
6033             if (j1.eq.j+1) then
6034 C Contacts I-J and (I+1)-J occur simultaneously.
6035 C The system loses extra energy.
6036 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6037             endif ! j1==j+1
6038           enddo ! kk
6039         enddo ! jj
6040       enddo ! i
6041       return
6042       end
6043 c------------------------------------------------------------------------------
6044       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6045      &  n_corr1)
6046 C This subroutine calculates multi-body contributions to hydrogen-bonding
6047       implicit real*8 (a-h,o-z)
6048       include 'DIMENSIONS'
6049       include 'DIMENSIONS.ZSCOPT'
6050       include 'COMMON.IOUNITS'
6051 #ifdef MPL
6052       include 'COMMON.INFO'
6053 #endif
6054       include 'COMMON.FFIELD'
6055       include 'COMMON.DERIV'
6056       include 'COMMON.INTERACT'
6057       include 'COMMON.CONTACTS'
6058 #ifdef MPL
6059       parameter (max_cont=maxconts)
6060       parameter (max_dim=2*(8*3+2))
6061       parameter (msglen1=max_cont*max_dim*4)
6062       parameter (msglen2=2*msglen1)
6063       integer source,CorrelType,CorrelID,Error
6064       double precision buffer(max_cont,max_dim)
6065 #endif
6066       double precision gx(3),gx1(3)
6067       logical lprn,ldone
6068
6069 C Set lprn=.true. for debugging
6070       lprn=.false.
6071       eturn6=0.0d0
6072       ecorr6=0.0d0
6073 #ifdef MPL
6074       n_corr=0
6075       n_corr1=0
6076       if (fgProcs.le.1) goto 30
6077       if (lprn) then
6078         write (iout,'(a)') 'Contact function values:'
6079         do i=nnt,nct-2
6080           write (iout,'(2i3,50(1x,i2,f5.2))')
6081      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6082      &    j=1,num_cont_hb(i))
6083         enddo
6084       endif
6085 C Caution! Following code assumes that electrostatic interactions concerning
6086 C a given atom are split among at most two processors!
6087       CorrelType=477
6088       CorrelID=MyID+1
6089       ldone=.false.
6090       do i=1,max_cont
6091         do j=1,max_dim
6092           buffer(i,j)=0.0D0
6093         enddo
6094       enddo
6095       mm=mod(MyRank,2)
6096 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6097       if (mm) 20,20,10
6098    10 continue
6099 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6100       if (MyRank.gt.0) then
6101 C Send correlation contributions to the preceding processor
6102         msglen=msglen1
6103         nn=num_cont_hb(iatel_s)
6104         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6105 cd      write (iout,*) 'The BUFFER array:'
6106 cd      do i=1,nn
6107 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6108 cd      enddo
6109         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6110           msglen=msglen2
6111             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6112 C Clear the contacts of the atom passed to the neighboring processor
6113         nn=num_cont_hb(iatel_s+1)
6114 cd      do i=1,nn
6115 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6116 cd      enddo
6117             num_cont_hb(iatel_s)=0
6118         endif
6119 cd      write (iout,*) 'Processor ',MyID,MyRank,
6120 cd   & ' is sending correlation contribution to processor',MyID-1,
6121 cd   & ' msglen=',msglen
6122 cd      write (*,*) 'Processor ',MyID,MyRank,
6123 cd   & ' is sending correlation contribution to processor',MyID-1,
6124 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6125         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6126 cd      write (iout,*) 'Processor ',MyID,
6127 cd   & ' has sent correlation contribution to processor',MyID-1,
6128 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6129 cd      write (*,*) 'Processor ',MyID,
6130 cd   & ' has sent correlation contribution to processor',MyID-1,
6131 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6132         msglen=msglen1
6133       endif ! (MyRank.gt.0)
6134       if (ldone) goto 30
6135       ldone=.true.
6136    20 continue
6137 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6138       if (MyRank.lt.fgProcs-1) then
6139 C Receive correlation contributions from the next processor
6140         msglen=msglen1
6141         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6142 cd      write (iout,*) 'Processor',MyID,
6143 cd   & ' is receiving correlation contribution from processor',MyID+1,
6144 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6145 cd      write (*,*) 'Processor',MyID,
6146 cd   & ' is receiving correlation contribution from processor',MyID+1,
6147 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6148         nbytes=-1
6149         do while (nbytes.le.0)
6150           call mp_probe(MyID+1,CorrelType,nbytes)
6151         enddo
6152 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6153         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6154 cd      write (iout,*) 'Processor',MyID,
6155 cd   & ' has received correlation contribution from processor',MyID+1,
6156 cd   & ' msglen=',msglen,' nbytes=',nbytes
6157 cd      write (iout,*) 'The received BUFFER array:'
6158 cd      do i=1,max_cont
6159 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6160 cd      enddo
6161         if (msglen.eq.msglen1) then
6162           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6163         else if (msglen.eq.msglen2)  then
6164           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6165           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6166         else
6167           write (iout,*)
6168      & 'ERROR!!!! message length changed while processing correlations.'
6169           write (*,*)
6170      & 'ERROR!!!! message length changed while processing correlations.'
6171           call mp_stopall(Error)
6172         endif ! msglen.eq.msglen1
6173       endif ! MyRank.lt.fgProcs-1
6174       if (ldone) goto 30
6175       ldone=.true.
6176       goto 10
6177    30 continue
6178 #endif
6179       if (lprn) then
6180         write (iout,'(a)') 'Contact function values:'
6181         do i=nnt,nct-2
6182           write (iout,'(2i3,50(1x,i2,f5.2))')
6183      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6184      &    j=1,num_cont_hb(i))
6185         enddo
6186       endif
6187       ecorr=0.0D0
6188       ecorr5=0.0d0
6189       ecorr6=0.0d0
6190 C Remove the loop below after debugging !!!
6191       do i=nnt,nct
6192         do j=1,3
6193           gradcorr(j,i)=0.0D0
6194           gradxorr(j,i)=0.0D0
6195         enddo
6196       enddo
6197 C Calculate the dipole-dipole interaction energies
6198       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6199       do i=iatel_s,iatel_e+1
6200         num_conti=num_cont_hb(i)
6201         do jj=1,num_conti
6202           j=jcont_hb(jj,i)
6203           call dipole(i,j,jj)
6204         enddo
6205       enddo
6206       endif
6207 C Calculate the local-electrostatic correlation terms
6208       do i=iatel_s,iatel_e+1
6209         i1=i+1
6210         num_conti=num_cont_hb(i)
6211         num_conti1=num_cont_hb(i+1)
6212         do jj=1,num_conti
6213           j=jcont_hb(jj,i)
6214           do kk=1,num_conti1
6215             j1=jcont_hb(kk,i1)
6216 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6217 c     &         ' jj=',jj,' kk=',kk
6218             if (j1.eq.j+1 .or. j1.eq.j-1) then
6219 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6220 C The system gains extra energy.
6221               n_corr=n_corr+1
6222               sqd1=dsqrt(d_cont(jj,i))
6223               sqd2=dsqrt(d_cont(kk,i1))
6224               sred_geom = sqd1*sqd2
6225               IF (sred_geom.lt.cutoff_corr) THEN
6226                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6227      &            ekont,fprimcont)
6228 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6229 c     &         ' jj=',jj,' kk=',kk
6230                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6231                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6232                 do l=1,3
6233                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6234                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6235                 enddo
6236                 n_corr1=n_corr1+1
6237 cd               write (iout,*) 'sred_geom=',sred_geom,
6238 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6239                 call calc_eello(i,j,i+1,j1,jj,kk)
6240                 if (wcorr4.gt.0.0d0)
6241      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6242                 if (wcorr5.gt.0.0d0)
6243      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6244 c                print *,"wcorr5",ecorr5
6245 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6246 cd                write(2,*)'ijkl',i,j,i+1,j1
6247                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6248      &               .or. wturn6.eq.0.0d0))then
6249 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6250                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6251 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6252 cd     &            'ecorr6=',ecorr6
6253 cd                write (iout,'(4e15.5)') sred_geom,
6254 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6255 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6256 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6257                 else if (wturn6.gt.0.0d0
6258      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6259 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6260                   eturn6=eturn6+eello_turn6(i,jj,kk)
6261 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6262                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6263                    eturn6=0.0d0
6264                    ecorr6=0.0d0
6265                 endif
6266
6267               ENDIF
6268 1111          continue
6269             else if (j1.eq.j) then
6270 C Contacts I-J and I-(J+1) occur simultaneously.
6271 C The system loses extra energy.
6272 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6273             endif
6274           enddo ! kk
6275           do kk=1,num_conti
6276             j1=jcont_hb(kk,i)
6277 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6278 c    &         ' jj=',jj,' kk=',kk
6279             if (j1.eq.j+1) then
6280 C Contacts I-J and (I+1)-J occur simultaneously.
6281 C The system loses extra energy.
6282 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6283             endif ! j1==j+1
6284           enddo ! kk
6285         enddo ! jj
6286       enddo ! i
6287       write (iout,*) "eturn6",eturn6,ecorr6
6288       return
6289       end
6290 c------------------------------------------------------------------------------
6291       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6292       implicit real*8 (a-h,o-z)
6293       include 'DIMENSIONS'
6294       include 'COMMON.IOUNITS'
6295       include 'COMMON.DERIV'
6296       include 'COMMON.INTERACT'
6297       include 'COMMON.CONTACTS'
6298       double precision gx(3),gx1(3)
6299       logical lprn
6300       lprn=.false.
6301       eij=facont_hb(jj,i)
6302       ekl=facont_hb(kk,k)
6303       ees0pij=ees0p(jj,i)
6304       ees0pkl=ees0p(kk,k)
6305       ees0mij=ees0m(jj,i)
6306       ees0mkl=ees0m(kk,k)
6307       ekont=eij*ekl
6308       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6309 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6310 C Following 4 lines for diagnostics.
6311 cd    ees0pkl=0.0D0
6312 cd    ees0pij=1.0D0
6313 cd    ees0mkl=0.0D0
6314 cd    ees0mij=1.0D0
6315 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6316 c    &   ' and',k,l
6317 c     write (iout,*)'Contacts have occurred for peptide groups',
6318 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6319 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6320 C Calculate the multi-body contribution to energy.
6321       ecorr=ecorr+ekont*ees
6322       if (calc_grad) then
6323 C Calculate multi-body contributions to the gradient.
6324       do ll=1,3
6325         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6326         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6327      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6328      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6329         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6330      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6331      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6332         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6333         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6334      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6335      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6336         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6337      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6338      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6339       enddo
6340       do m=i+1,j-1
6341         do ll=1,3
6342           gradcorr(ll,m)=gradcorr(ll,m)+
6343      &     ees*ekl*gacont_hbr(ll,jj,i)-
6344      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6345      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6346         enddo
6347       enddo
6348       do m=k+1,l-1
6349         do ll=1,3
6350           gradcorr(ll,m)=gradcorr(ll,m)+
6351      &     ees*eij*gacont_hbr(ll,kk,k)-
6352      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6353      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6354         enddo
6355       enddo
6356       endif
6357       ehbcorr=ekont*ees
6358       return
6359       end
6360 C---------------------------------------------------------------------------
6361       subroutine dipole(i,j,jj)
6362       implicit real*8 (a-h,o-z)
6363       include 'DIMENSIONS'
6364       include 'DIMENSIONS.ZSCOPT'
6365       include 'COMMON.IOUNITS'
6366       include 'COMMON.CHAIN'
6367       include 'COMMON.FFIELD'
6368       include 'COMMON.DERIV'
6369       include 'COMMON.INTERACT'
6370       include 'COMMON.CONTACTS'
6371       include 'COMMON.TORSION'
6372       include 'COMMON.VAR'
6373       include 'COMMON.GEO'
6374       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6375      &  auxmat(2,2)
6376       iti1 = itortyp(itype(i+1))
6377       if (j.lt.nres-1) then
6378         if (itype(j).le.ntyp) then
6379           itj1 = itortyp(itype(j+1))
6380         else
6381           itj=ntortyp+1
6382         endif
6383       else
6384         itj1=ntortyp+1
6385       endif
6386       do iii=1,2
6387         dipi(iii,1)=Ub2(iii,i)
6388         dipderi(iii)=Ub2der(iii,i)
6389         dipi(iii,2)=b1(iii,iti1)
6390         dipj(iii,1)=Ub2(iii,j)
6391         dipderj(iii)=Ub2der(iii,j)
6392         dipj(iii,2)=b1(iii,itj1)
6393       enddo
6394       kkk=0
6395       do iii=1,2
6396         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6397         do jjj=1,2
6398           kkk=kkk+1
6399           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6400         enddo
6401       enddo
6402       if (.not.calc_grad) return
6403       do kkk=1,5
6404         do lll=1,3
6405           mmm=0
6406           do iii=1,2
6407             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6408      &        auxvec(1))
6409             do jjj=1,2
6410               mmm=mmm+1
6411               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6412             enddo
6413           enddo
6414         enddo
6415       enddo
6416       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6417       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6418       do iii=1,2
6419         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6420       enddo
6421       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6422       do iii=1,2
6423         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6424       enddo
6425       return
6426       end
6427 C---------------------------------------------------------------------------
6428       subroutine calc_eello(i,j,k,l,jj,kk)
6429 C
6430 C This subroutine computes matrices and vectors needed to calculate
6431 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6432 C
6433       implicit real*8 (a-h,o-z)
6434       include 'DIMENSIONS'
6435       include 'DIMENSIONS.ZSCOPT'
6436       include 'COMMON.IOUNITS'
6437       include 'COMMON.CHAIN'
6438       include 'COMMON.DERIV'
6439       include 'COMMON.INTERACT'
6440       include 'COMMON.CONTACTS'
6441       include 'COMMON.TORSION'
6442       include 'COMMON.VAR'
6443       include 'COMMON.GEO'
6444       include 'COMMON.FFIELD'
6445       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6446      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6447       logical lprn
6448       common /kutas/ lprn
6449 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6450 cd     & ' jj=',jj,' kk=',kk
6451 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6452       do iii=1,2
6453         do jjj=1,2
6454           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6455           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6456         enddo
6457       enddo
6458       call transpose2(aa1(1,1),aa1t(1,1))
6459       call transpose2(aa2(1,1),aa2t(1,1))
6460       do kkk=1,5
6461         do lll=1,3
6462           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6463      &      aa1tder(1,1,lll,kkk))
6464           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6465      &      aa2tder(1,1,lll,kkk))
6466         enddo
6467       enddo
6468       if (l.eq.j+1) then
6469 C parallel orientation of the two CA-CA-CA frames.
6470         if (i.gt.1 .and. itype(i).le.ntyp) then
6471           iti=itortyp(itype(i))
6472         else
6473           iti=ntortyp+1
6474         endif
6475         itk1=itortyp(itype(k+1))
6476         itj=itortyp(itype(j))
6477         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6478           itl1=itortyp(itype(l+1))
6479         else
6480           itl1=ntortyp+1
6481         endif
6482 C A1 kernel(j+1) A2T
6483 cd        do iii=1,2
6484 cd          write (iout,'(3f10.5,5x,3f10.5)')
6485 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6486 cd        enddo
6487         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6488      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6489      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6490 C Following matrices are needed only for 6-th order cumulants
6491         IF (wcorr6.gt.0.0d0) THEN
6492         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6493      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6494      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6495         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6496      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6497      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6498      &   ADtEAderx(1,1,1,1,1,1))
6499         lprn=.false.
6500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6501      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6502      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6503      &   ADtEA1derx(1,1,1,1,1,1))
6504         ENDIF
6505 C End 6-th order cumulants
6506 cd        lprn=.false.
6507 cd        if (lprn) then
6508 cd        write (2,*) 'In calc_eello6'
6509 cd        do iii=1,2
6510 cd          write (2,*) 'iii=',iii
6511 cd          do kkk=1,5
6512 cd            write (2,*) 'kkk=',kkk
6513 cd            do jjj=1,2
6514 cd              write (2,'(3(2f10.5),5x)')
6515 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6516 cd            enddo
6517 cd          enddo
6518 cd        enddo
6519 cd        endif
6520         call transpose2(EUgder(1,1,k),auxmat(1,1))
6521         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6522         call transpose2(EUg(1,1,k),auxmat(1,1))
6523         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6524         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6525         do iii=1,2
6526           do kkk=1,5
6527             do lll=1,3
6528               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6529      &          EAEAderx(1,1,lll,kkk,iii,1))
6530             enddo
6531           enddo
6532         enddo
6533 C A1T kernel(i+1) A2
6534         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6535      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6536      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6537 C Following matrices are needed only for 6-th order cumulants
6538         IF (wcorr6.gt.0.0d0) THEN
6539         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6540      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6541      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6542         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6543      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6544      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6545      &   ADtEAderx(1,1,1,1,1,2))
6546         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6547      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6548      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6549      &   ADtEA1derx(1,1,1,1,1,2))
6550         ENDIF
6551 C End 6-th order cumulants
6552         call transpose2(EUgder(1,1,l),auxmat(1,1))
6553         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6554         call transpose2(EUg(1,1,l),auxmat(1,1))
6555         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6556         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6557         do iii=1,2
6558           do kkk=1,5
6559             do lll=1,3
6560               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6561      &          EAEAderx(1,1,lll,kkk,iii,2))
6562             enddo
6563           enddo
6564         enddo
6565 C AEAb1 and AEAb2
6566 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6567 C They are needed only when the fifth- or the sixth-order cumulants are
6568 C indluded.
6569         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6570         call transpose2(AEA(1,1,1),auxmat(1,1))
6571         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6572         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6573         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6574         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6575         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6576         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6577         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6578         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6579         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6580         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6581         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6582         call transpose2(AEA(1,1,2),auxmat(1,1))
6583         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6584         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6585         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6586         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6587         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6588         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6589         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6590         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6591         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6592         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6593         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6594 C Calculate the Cartesian derivatives of the vectors.
6595         do iii=1,2
6596           do kkk=1,5
6597             do lll=1,3
6598               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6599               call matvec2(auxmat(1,1),b1(1,iti),
6600      &          AEAb1derx(1,lll,kkk,iii,1,1))
6601               call matvec2(auxmat(1,1),Ub2(1,i),
6602      &          AEAb2derx(1,lll,kkk,iii,1,1))
6603               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6604      &          AEAb1derx(1,lll,kkk,iii,2,1))
6605               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6606      &          AEAb2derx(1,lll,kkk,iii,2,1))
6607               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6608               call matvec2(auxmat(1,1),b1(1,itj),
6609      &          AEAb1derx(1,lll,kkk,iii,1,2))
6610               call matvec2(auxmat(1,1),Ub2(1,j),
6611      &          AEAb2derx(1,lll,kkk,iii,1,2))
6612               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6613      &          AEAb1derx(1,lll,kkk,iii,2,2))
6614               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6615      &          AEAb2derx(1,lll,kkk,iii,2,2))
6616             enddo
6617           enddo
6618         enddo
6619         ENDIF
6620 C End vectors
6621       else
6622 C Antiparallel orientation of the two CA-CA-CA frames.
6623         if (i.gt.1 .and. itype(i).le.ntyp) then
6624           iti=itortyp(itype(i))
6625         else
6626           iti=ntortyp+1
6627         endif
6628         itk1=itortyp(itype(k+1))
6629         itl=itortyp(itype(l))
6630         itj=itortyp(itype(j))
6631         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6632           itj1=itortyp(itype(j+1))
6633         else
6634           itj1=ntortyp+1
6635         endif
6636 C A2 kernel(j-1)T A1T
6637         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6638      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6639      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6640 C Following matrices are needed only for 6-th order cumulants
6641         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6642      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6643         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6644      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6645      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6646         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6647      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6648      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6649      &   ADtEAderx(1,1,1,1,1,1))
6650         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6651      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6652      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6653      &   ADtEA1derx(1,1,1,1,1,1))
6654         ENDIF
6655 C End 6-th order cumulants
6656         call transpose2(EUgder(1,1,k),auxmat(1,1))
6657         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6658         call transpose2(EUg(1,1,k),auxmat(1,1))
6659         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6660         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6661         do iii=1,2
6662           do kkk=1,5
6663             do lll=1,3
6664               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6665      &          EAEAderx(1,1,lll,kkk,iii,1))
6666             enddo
6667           enddo
6668         enddo
6669 C A2T kernel(i+1)T A1
6670         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6671      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6672      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6673 C Following matrices are needed only for 6-th order cumulants
6674         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6675      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6676         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6677      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6678      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6679         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6680      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6681      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6682      &   ADtEAderx(1,1,1,1,1,2))
6683         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6684      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6685      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6686      &   ADtEA1derx(1,1,1,1,1,2))
6687         ENDIF
6688 C End 6-th order cumulants
6689         call transpose2(EUgder(1,1,j),auxmat(1,1))
6690         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6691         call transpose2(EUg(1,1,j),auxmat(1,1))
6692         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6693         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6694         do iii=1,2
6695           do kkk=1,5
6696             do lll=1,3
6697               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6698      &          EAEAderx(1,1,lll,kkk,iii,2))
6699             enddo
6700           enddo
6701         enddo
6702 C AEAb1 and AEAb2
6703 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6704 C They are needed only when the fifth- or the sixth-order cumulants are
6705 C indluded.
6706         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6707      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6708         call transpose2(AEA(1,1,1),auxmat(1,1))
6709         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6710         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6711         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6712         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6713         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6714         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6715         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6716         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6717         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6718         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6719         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6720         call transpose2(AEA(1,1,2),auxmat(1,1))
6721         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6722         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6723         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6724         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6725         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6726         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6727         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6728         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6729         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6730         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6731         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6732 C Calculate the Cartesian derivatives of the vectors.
6733         do iii=1,2
6734           do kkk=1,5
6735             do lll=1,3
6736               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6737               call matvec2(auxmat(1,1),b1(1,iti),
6738      &          AEAb1derx(1,lll,kkk,iii,1,1))
6739               call matvec2(auxmat(1,1),Ub2(1,i),
6740      &          AEAb2derx(1,lll,kkk,iii,1,1))
6741               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6742      &          AEAb1derx(1,lll,kkk,iii,2,1))
6743               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6744      &          AEAb2derx(1,lll,kkk,iii,2,1))
6745               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6746               call matvec2(auxmat(1,1),b1(1,itl),
6747      &          AEAb1derx(1,lll,kkk,iii,1,2))
6748               call matvec2(auxmat(1,1),Ub2(1,l),
6749      &          AEAb2derx(1,lll,kkk,iii,1,2))
6750               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6751      &          AEAb1derx(1,lll,kkk,iii,2,2))
6752               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6753      &          AEAb2derx(1,lll,kkk,iii,2,2))
6754             enddo
6755           enddo
6756         enddo
6757         ENDIF
6758 C End vectors
6759       endif
6760       return
6761       end
6762 C---------------------------------------------------------------------------
6763       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6764      &  KK,KKderg,AKA,AKAderg,AKAderx)
6765       implicit none
6766       integer nderg
6767       logical transp
6768       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6769      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6770      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6771       integer iii,kkk,lll
6772       integer jjj,mmm
6773       logical lprn
6774       common /kutas/ lprn
6775       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6776       do iii=1,nderg
6777         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6778      &    AKAderg(1,1,iii))
6779       enddo
6780 cd      if (lprn) write (2,*) 'In kernel'
6781       do kkk=1,5
6782 cd        if (lprn) write (2,*) 'kkk=',kkk
6783         do lll=1,3
6784           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6785      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6786 cd          if (lprn) then
6787 cd            write (2,*) 'lll=',lll
6788 cd            write (2,*) 'iii=1'
6789 cd            do jjj=1,2
6790 cd              write (2,'(3(2f10.5),5x)')
6791 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6792 cd            enddo
6793 cd          endif
6794           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6795      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6796 cd          if (lprn) then
6797 cd            write (2,*) 'lll=',lll
6798 cd            write (2,*) 'iii=2'
6799 cd            do jjj=1,2
6800 cd              write (2,'(3(2f10.5),5x)')
6801 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6802 cd            enddo
6803 cd          endif
6804         enddo
6805       enddo
6806       return
6807       end
6808 C---------------------------------------------------------------------------
6809       double precision function eello4(i,j,k,l,jj,kk)
6810       implicit real*8 (a-h,o-z)
6811       include 'DIMENSIONS'
6812       include 'DIMENSIONS.ZSCOPT'
6813       include 'COMMON.IOUNITS'
6814       include 'COMMON.CHAIN'
6815       include 'COMMON.DERIV'
6816       include 'COMMON.INTERACT'
6817       include 'COMMON.CONTACTS'
6818       include 'COMMON.TORSION'
6819       include 'COMMON.VAR'
6820       include 'COMMON.GEO'
6821       double precision pizda(2,2),ggg1(3),ggg2(3)
6822 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6823 cd        eello4=0.0d0
6824 cd        return
6825 cd      endif
6826 cd      print *,'eello4:',i,j,k,l,jj,kk
6827 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6828 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6829 cold      eij=facont_hb(jj,i)
6830 cold      ekl=facont_hb(kk,k)
6831 cold      ekont=eij*ekl
6832       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6833       if (calc_grad) then
6834 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6835       gcorr_loc(k-1)=gcorr_loc(k-1)
6836      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6837       if (l.eq.j+1) then
6838         gcorr_loc(l-1)=gcorr_loc(l-1)
6839      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6840       else
6841         gcorr_loc(j-1)=gcorr_loc(j-1)
6842      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6843       endif
6844       do iii=1,2
6845         do kkk=1,5
6846           do lll=1,3
6847             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6848      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6849 cd            derx(lll,kkk,iii)=0.0d0
6850           enddo
6851         enddo
6852       enddo
6853 cd      gcorr_loc(l-1)=0.0d0
6854 cd      gcorr_loc(j-1)=0.0d0
6855 cd      gcorr_loc(k-1)=0.0d0
6856 cd      eel4=1.0d0
6857 cd      write (iout,*)'Contacts have occurred for peptide groups',
6858 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6859 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6860       if (j.lt.nres-1) then
6861         j1=j+1
6862         j2=j-1
6863       else
6864         j1=j-1
6865         j2=j-2
6866       endif
6867       if (l.lt.nres-1) then
6868         l1=l+1
6869         l2=l-1
6870       else
6871         l1=l-1
6872         l2=l-2
6873       endif
6874       do ll=1,3
6875 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6876         ggg1(ll)=eel4*g_contij(ll,1)
6877         ggg2(ll)=eel4*g_contij(ll,2)
6878         ghalf=0.5d0*ggg1(ll)
6879 cd        ghalf=0.0d0
6880         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6881         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6882         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6883         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6884 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6885         ghalf=0.5d0*ggg2(ll)
6886 cd        ghalf=0.0d0
6887         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6888         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6889         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6890         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6891       enddo
6892 cd      goto 1112
6893       do m=i+1,j-1
6894         do ll=1,3
6895 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6896           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6897         enddo
6898       enddo
6899       do m=k+1,l-1
6900         do ll=1,3
6901 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6902           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6903         enddo
6904       enddo
6905 1112  continue
6906       do m=i+2,j2
6907         do ll=1,3
6908           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6909         enddo
6910       enddo
6911       do m=k+2,l2
6912         do ll=1,3
6913           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6914         enddo
6915       enddo
6916 cd      do iii=1,nres-3
6917 cd        write (2,*) iii,gcorr_loc(iii)
6918 cd      enddo
6919       endif
6920       eello4=ekont*eel4
6921 cd      write (2,*) 'ekont',ekont
6922 cd      write (iout,*) 'eello4',ekont*eel4
6923       return
6924       end
6925 C---------------------------------------------------------------------------
6926       double precision function eello5(i,j,k,l,jj,kk)
6927       implicit real*8 (a-h,o-z)
6928       include 'DIMENSIONS'
6929       include 'DIMENSIONS.ZSCOPT'
6930       include 'COMMON.IOUNITS'
6931       include 'COMMON.CHAIN'
6932       include 'COMMON.DERIV'
6933       include 'COMMON.INTERACT'
6934       include 'COMMON.CONTACTS'
6935       include 'COMMON.TORSION'
6936       include 'COMMON.VAR'
6937       include 'COMMON.GEO'
6938       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6939       double precision ggg1(3),ggg2(3)
6940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6941 C                                                                              C
6942 C                            Parallel chains                                   C
6943 C                                                                              C
6944 C          o             o                   o             o                   C
6945 C         /l\           / \             \   / \           / \   /              C
6946 C        /   \         /   \             \ /   \         /   \ /               C
6947 C       j| o |l1       | o |              o| o |         | o |o                C
6948 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6949 C      \i/   \         /   \ /             /   \         /   \                 C
6950 C       o    k1             o                                                  C
6951 C         (I)          (II)                (III)          (IV)                 C
6952 C                                                                              C
6953 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6954 C                                                                              C
6955 C                            Antiparallel chains                               C
6956 C                                                                              C
6957 C          o             o                   o             o                   C
6958 C         /j\           / \             \   / \           / \   /              C
6959 C        /   \         /   \             \ /   \         /   \ /               C
6960 C      j1| o |l        | o |              o| o |         | o |o                C
6961 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6962 C      \i/   \         /   \ /             /   \         /   \                 C
6963 C       o     k1            o                                                  C
6964 C         (I)          (II)                (III)          (IV)                 C
6965 C                                                                              C
6966 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6967 C                                                                              C
6968 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6969 C                                                                              C
6970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6971 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6972 cd        eello5=0.0d0
6973 cd        return
6974 cd      endif
6975 cd      write (iout,*)
6976 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6977 cd     &   ' and',k,l
6978       itk=itortyp(itype(k))
6979       itl=itortyp(itype(l))
6980       itj=itortyp(itype(j))
6981       eello5_1=0.0d0
6982       eello5_2=0.0d0
6983       eello5_3=0.0d0
6984       eello5_4=0.0d0
6985 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6986 cd     &   eel5_3_num,eel5_4_num)
6987       do iii=1,2
6988         do kkk=1,5
6989           do lll=1,3
6990             derx(lll,kkk,iii)=0.0d0
6991           enddo
6992         enddo
6993       enddo
6994 cd      eij=facont_hb(jj,i)
6995 cd      ekl=facont_hb(kk,k)
6996 cd      ekont=eij*ekl
6997 cd      write (iout,*)'Contacts have occurred for peptide groups',
6998 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6999 cd      goto 1111
7000 C Contribution from the graph I.
7001 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7002 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7003       call transpose2(EUg(1,1,k),auxmat(1,1))
7004       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7005       vv(1)=pizda(1,1)-pizda(2,2)
7006       vv(2)=pizda(1,2)+pizda(2,1)
7007       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7008      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7009       if (calc_grad) then
7010 C Explicit gradient in virtual-dihedral angles.
7011       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7012      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7013      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7014       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7015       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7016       vv(1)=pizda(1,1)-pizda(2,2)
7017       vv(2)=pizda(1,2)+pizda(2,1)
7018       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7019      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7020      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7021       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7022       vv(1)=pizda(1,1)-pizda(2,2)
7023       vv(2)=pizda(1,2)+pizda(2,1)
7024       if (l.eq.j+1) then
7025         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7026      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7027      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7028       else
7029         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7030      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7031      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7032       endif
7033 C Cartesian gradient
7034       do iii=1,2
7035         do kkk=1,5
7036           do lll=1,3
7037             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7038      &        pizda(1,1))
7039             vv(1)=pizda(1,1)-pizda(2,2)
7040             vv(2)=pizda(1,2)+pizda(2,1)
7041             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7042      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7043      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7044           enddo
7045         enddo
7046       enddo
7047 c      goto 1112
7048       endif
7049 c1111  continue
7050 C Contribution from graph II
7051       call transpose2(EE(1,1,itk),auxmat(1,1))
7052       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7053       vv(1)=pizda(1,1)+pizda(2,2)
7054       vv(2)=pizda(2,1)-pizda(1,2)
7055       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7056      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7057       if (calc_grad) then
7058 C Explicit gradient in virtual-dihedral angles.
7059       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7060      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7061       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7062       vv(1)=pizda(1,1)+pizda(2,2)
7063       vv(2)=pizda(2,1)-pizda(1,2)
7064       if (l.eq.j+1) then
7065         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7066      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7067      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7068       else
7069         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7070      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7071      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7072       endif
7073 C Cartesian gradient
7074       do iii=1,2
7075         do kkk=1,5
7076           do lll=1,3
7077             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7078      &        pizda(1,1))
7079             vv(1)=pizda(1,1)+pizda(2,2)
7080             vv(2)=pizda(2,1)-pizda(1,2)
7081             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7082      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7083      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7084           enddo
7085         enddo
7086       enddo
7087 cd      goto 1112
7088       endif
7089 cd1111  continue
7090       if (l.eq.j+1) then
7091 cd        goto 1110
7092 C Parallel orientation
7093 C Contribution from graph III
7094         call transpose2(EUg(1,1,l),auxmat(1,1))
7095         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7096         vv(1)=pizda(1,1)-pizda(2,2)
7097         vv(2)=pizda(1,2)+pizda(2,1)
7098         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7099      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7100         if (calc_grad) then
7101 C Explicit gradient in virtual-dihedral angles.
7102         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7103      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7104      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7105         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7106         vv(1)=pizda(1,1)-pizda(2,2)
7107         vv(2)=pizda(1,2)+pizda(2,1)
7108         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7109      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7110      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7111         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7112         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7113         vv(1)=pizda(1,1)-pizda(2,2)
7114         vv(2)=pizda(1,2)+pizda(2,1)
7115         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7116      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7117      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7118 C Cartesian gradient
7119         do iii=1,2
7120           do kkk=1,5
7121             do lll=1,3
7122               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7123      &          pizda(1,1))
7124               vv(1)=pizda(1,1)-pizda(2,2)
7125               vv(2)=pizda(1,2)+pizda(2,1)
7126               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7127      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7128      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7129             enddo
7130           enddo
7131         enddo
7132 cd        goto 1112
7133         endif
7134 C Contribution from graph IV
7135 cd1110    continue
7136         call transpose2(EE(1,1,itl),auxmat(1,1))
7137         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7138         vv(1)=pizda(1,1)+pizda(2,2)
7139         vv(2)=pizda(2,1)-pizda(1,2)
7140         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7141      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7142         if (calc_grad) then
7143 C Explicit gradient in virtual-dihedral angles.
7144         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7145      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7146         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7147         vv(1)=pizda(1,1)+pizda(2,2)
7148         vv(2)=pizda(2,1)-pizda(1,2)
7149         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7150      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7151      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7152 C Cartesian gradient
7153         do iii=1,2
7154           do kkk=1,5
7155             do lll=1,3
7156               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7157      &          pizda(1,1))
7158               vv(1)=pizda(1,1)+pizda(2,2)
7159               vv(2)=pizda(2,1)-pizda(1,2)
7160               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7161      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7162      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7163             enddo
7164           enddo
7165         enddo
7166         endif
7167       else
7168 C Antiparallel orientation
7169 C Contribution from graph III
7170 c        goto 1110
7171         call transpose2(EUg(1,1,j),auxmat(1,1))
7172         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7173         vv(1)=pizda(1,1)-pizda(2,2)
7174         vv(2)=pizda(1,2)+pizda(2,1)
7175         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7176      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7177         if (calc_grad) then
7178 C Explicit gradient in virtual-dihedral angles.
7179         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7180      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7181      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7182         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7183         vv(1)=pizda(1,1)-pizda(2,2)
7184         vv(2)=pizda(1,2)+pizda(2,1)
7185         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7186      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7187      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7188         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7189         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7190         vv(1)=pizda(1,1)-pizda(2,2)
7191         vv(2)=pizda(1,2)+pizda(2,1)
7192         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7193      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7194      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7195 C Cartesian gradient
7196         do iii=1,2
7197           do kkk=1,5
7198             do lll=1,3
7199               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7200      &          pizda(1,1))
7201               vv(1)=pizda(1,1)-pizda(2,2)
7202               vv(2)=pizda(1,2)+pizda(2,1)
7203               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7204      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7205      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7206             enddo
7207           enddo
7208         enddo
7209 cd        goto 1112
7210         endif
7211 C Contribution from graph IV
7212 1110    continue
7213         call transpose2(EE(1,1,itj),auxmat(1,1))
7214         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7215         vv(1)=pizda(1,1)+pizda(2,2)
7216         vv(2)=pizda(2,1)-pizda(1,2)
7217         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7218      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7219         if (calc_grad) then
7220 C Explicit gradient in virtual-dihedral angles.
7221         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7222      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7223         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7224         vv(1)=pizda(1,1)+pizda(2,2)
7225         vv(2)=pizda(2,1)-pizda(1,2)
7226         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7227      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7228      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7229 C Cartesian gradient
7230         do iii=1,2
7231           do kkk=1,5
7232             do lll=1,3
7233               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7234      &          pizda(1,1))
7235               vv(1)=pizda(1,1)+pizda(2,2)
7236               vv(2)=pizda(2,1)-pizda(1,2)
7237               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7238      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7239      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7240             enddo
7241           enddo
7242         enddo
7243       endif
7244       endif
7245 1112  continue
7246       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7247 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7248 cd        write (2,*) 'ijkl',i,j,k,l
7249 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7250 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7251 cd      endif
7252 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7253 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7254 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7255 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7256       if (calc_grad) then
7257       if (j.lt.nres-1) then
7258         j1=j+1
7259         j2=j-1
7260       else
7261         j1=j-1
7262         j2=j-2
7263       endif
7264       if (l.lt.nres-1) then
7265         l1=l+1
7266         l2=l-1
7267       else
7268         l1=l-1
7269         l2=l-2
7270       endif
7271 cd      eij=1.0d0
7272 cd      ekl=1.0d0
7273 cd      ekont=1.0d0
7274 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7275       do ll=1,3
7276         ggg1(ll)=eel5*g_contij(ll,1)
7277         ggg2(ll)=eel5*g_contij(ll,2)
7278 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7279         ghalf=0.5d0*ggg1(ll)
7280 cd        ghalf=0.0d0
7281         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7282         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7283         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7284         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7285 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7286         ghalf=0.5d0*ggg2(ll)
7287 cd        ghalf=0.0d0
7288         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7289         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7290         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7291         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7292       enddo
7293 cd      goto 1112
7294       do m=i+1,j-1
7295         do ll=1,3
7296 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7297           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7298         enddo
7299       enddo
7300       do m=k+1,l-1
7301         do ll=1,3
7302 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7303           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7304         enddo
7305       enddo
7306 c1112  continue
7307       do m=i+2,j2
7308         do ll=1,3
7309           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7310         enddo
7311       enddo
7312       do m=k+2,l2
7313         do ll=1,3
7314           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7315         enddo
7316       enddo
7317 cd      do iii=1,nres-3
7318 cd        write (2,*) iii,g_corr5_loc(iii)
7319 cd      enddo
7320       endif
7321       eello5=ekont*eel5
7322 cd      write (2,*) 'ekont',ekont
7323 cd      write (iout,*) 'eello5',ekont*eel5
7324       return
7325       end
7326 c--------------------------------------------------------------------------
7327       double precision function eello6(i,j,k,l,jj,kk)
7328       implicit real*8 (a-h,o-z)
7329       include 'DIMENSIONS'
7330       include 'DIMENSIONS.ZSCOPT'
7331       include 'COMMON.IOUNITS'
7332       include 'COMMON.CHAIN'
7333       include 'COMMON.DERIV'
7334       include 'COMMON.INTERACT'
7335       include 'COMMON.CONTACTS'
7336       include 'COMMON.TORSION'
7337       include 'COMMON.VAR'
7338       include 'COMMON.GEO'
7339       include 'COMMON.FFIELD'
7340       double precision ggg1(3),ggg2(3)
7341 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7342 cd        eello6=0.0d0
7343 cd        return
7344 cd      endif
7345 cd      write (iout,*)
7346 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7347 cd     &   ' and',k,l
7348       eello6_1=0.0d0
7349       eello6_2=0.0d0
7350       eello6_3=0.0d0
7351       eello6_4=0.0d0
7352       eello6_5=0.0d0
7353       eello6_6=0.0d0
7354 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7355 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7356       do iii=1,2
7357         do kkk=1,5
7358           do lll=1,3
7359             derx(lll,kkk,iii)=0.0d0
7360           enddo
7361         enddo
7362       enddo
7363 cd      eij=facont_hb(jj,i)
7364 cd      ekl=facont_hb(kk,k)
7365 cd      ekont=eij*ekl
7366 cd      eij=1.0d0
7367 cd      ekl=1.0d0
7368 cd      ekont=1.0d0
7369       if (l.eq.j+1) then
7370         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7371         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7372         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7373         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7374         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7375         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7376       else
7377         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7378         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7379         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7380         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7381         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7382           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7383         else
7384           eello6_5=0.0d0
7385         endif
7386         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7387       endif
7388 C If turn contributions are considered, they will be handled separately.
7389       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7390 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7391 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7392 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7393 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7394 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7395 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7396 cd      goto 1112
7397       if (calc_grad) then
7398       if (j.lt.nres-1) then
7399         j1=j+1
7400         j2=j-1
7401       else
7402         j1=j-1
7403         j2=j-2
7404       endif
7405       if (l.lt.nres-1) then
7406         l1=l+1
7407         l2=l-1
7408       else
7409         l1=l-1
7410         l2=l-2
7411       endif
7412       do ll=1,3
7413         ggg1(ll)=eel6*g_contij(ll,1)
7414         ggg2(ll)=eel6*g_contij(ll,2)
7415 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7416         ghalf=0.5d0*ggg1(ll)
7417 cd        ghalf=0.0d0
7418         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7419         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7420         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7421         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7422         ghalf=0.5d0*ggg2(ll)
7423 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7424 cd        ghalf=0.0d0
7425         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7426         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7427         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7428         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7429       enddo
7430 cd      goto 1112
7431       do m=i+1,j-1
7432         do ll=1,3
7433 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7434           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7435         enddo
7436       enddo
7437       do m=k+1,l-1
7438         do ll=1,3
7439 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7440           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7441         enddo
7442       enddo
7443 1112  continue
7444       do m=i+2,j2
7445         do ll=1,3
7446           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7447         enddo
7448       enddo
7449       do m=k+2,l2
7450         do ll=1,3
7451           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7452         enddo
7453       enddo
7454 cd      do iii=1,nres-3
7455 cd        write (2,*) iii,g_corr6_loc(iii)
7456 cd      enddo
7457       endif
7458       eello6=ekont*eel6
7459 cd      write (2,*) 'ekont',ekont
7460 cd      write (iout,*) 'eello6',ekont*eel6
7461       return
7462       end
7463 c--------------------------------------------------------------------------
7464       double precision function eello6_graph1(i,j,k,l,imat,swap)
7465       implicit real*8 (a-h,o-z)
7466       include 'DIMENSIONS'
7467       include 'DIMENSIONS.ZSCOPT'
7468       include 'COMMON.IOUNITS'
7469       include 'COMMON.CHAIN'
7470       include 'COMMON.DERIV'
7471       include 'COMMON.INTERACT'
7472       include 'COMMON.CONTACTS'
7473       include 'COMMON.TORSION'
7474       include 'COMMON.VAR'
7475       include 'COMMON.GEO'
7476       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7477       logical swap
7478       logical lprn
7479       common /kutas/ lprn
7480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7481 C                                                                              C
7482 C      Parallel       Antiparallel                                             C
7483 C                                                                              C
7484 C          o             o                                                     C
7485 C         /l\           /j\                                                    C
7486 C        /   \         /   \                                                   C
7487 C       /| o |         | o |\                                                  C
7488 C     \ j|/k\|  /   \  |/k\|l /                                                C
7489 C      \ /   \ /     \ /   \ /                                                 C
7490 C       o     o       o     o                                                  C
7491 C       i             i                                                        C
7492 C                                                                              C
7493 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7494       itk=itortyp(itype(k))
7495       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7496       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7497       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7498       call transpose2(EUgC(1,1,k),auxmat(1,1))
7499       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7500       vv1(1)=pizda1(1,1)-pizda1(2,2)
7501       vv1(2)=pizda1(1,2)+pizda1(2,1)
7502       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7503       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7504       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7505       s5=scalar2(vv(1),Dtobr2(1,i))
7506 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7507       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7508       if (.not. calc_grad) return
7509       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7510      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7511      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7512      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7513      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7514      & +scalar2(vv(1),Dtobr2der(1,i)))
7515       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7516       vv1(1)=pizda1(1,1)-pizda1(2,2)
7517       vv1(2)=pizda1(1,2)+pizda1(2,1)
7518       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7519       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7520       if (l.eq.j+1) then
7521         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7522      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7523      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7524      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7525      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7526       else
7527         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7528      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7529      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7530      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7531      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7532       endif
7533       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7534       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7535       vv1(1)=pizda1(1,1)-pizda1(2,2)
7536       vv1(2)=pizda1(1,2)+pizda1(2,1)
7537       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7538      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7539      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7540      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7541       do iii=1,2
7542         if (swap) then
7543           ind=3-iii
7544         else
7545           ind=iii
7546         endif
7547         do kkk=1,5
7548           do lll=1,3
7549             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7550             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7551             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7552             call transpose2(EUgC(1,1,k),auxmat(1,1))
7553             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7554      &        pizda1(1,1))
7555             vv1(1)=pizda1(1,1)-pizda1(2,2)
7556             vv1(2)=pizda1(1,2)+pizda1(2,1)
7557             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7558             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7559      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7560             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7561      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7562             s5=scalar2(vv(1),Dtobr2(1,i))
7563             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7564           enddo
7565         enddo
7566       enddo
7567       return
7568       end
7569 c----------------------------------------------------------------------------
7570       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7571       implicit real*8 (a-h,o-z)
7572       include 'DIMENSIONS'
7573       include 'DIMENSIONS.ZSCOPT'
7574       include 'COMMON.IOUNITS'
7575       include 'COMMON.CHAIN'
7576       include 'COMMON.DERIV'
7577       include 'COMMON.INTERACT'
7578       include 'COMMON.CONTACTS'
7579       include 'COMMON.TORSION'
7580       include 'COMMON.VAR'
7581       include 'COMMON.GEO'
7582       logical swap
7583       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7584      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7585       logical lprn
7586       common /kutas/ lprn
7587 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7588 C                                                                              C
7589 C      Parallel       Antiparallel                                             C
7590 C                                                                              C
7591 C          o             o                                                     C
7592 C     \   /l\           /j\   /                                                C
7593 C      \ /   \         /   \ /                                                 C
7594 C       o| o |         | o |o                                                  C
7595 C     \ j|/k\|      \  |/k\|l                                                  C
7596 C      \ /   \       \ /   \                                                   C
7597 C       o             o                                                        C
7598 C       i             i                                                        C
7599 C                                                                              C
7600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7601 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7602 C AL 7/4/01 s1 would occur in the sixth-order moment,
7603 C           but not in a cluster cumulant
7604 #ifdef MOMENT
7605       s1=dip(1,jj,i)*dip(1,kk,k)
7606 #endif
7607       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7608       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7609       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7610       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7611       call transpose2(EUg(1,1,k),auxmat(1,1))
7612       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7613       vv(1)=pizda(1,1)-pizda(2,2)
7614       vv(2)=pizda(1,2)+pizda(2,1)
7615       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7616 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7617 #ifdef MOMENT
7618       eello6_graph2=-(s1+s2+s3+s4)
7619 #else
7620       eello6_graph2=-(s2+s3+s4)
7621 #endif
7622 c      eello6_graph2=-s3
7623       if (.not. calc_grad) return
7624 C Derivatives in gamma(i-1)
7625       if (i.gt.1) then
7626 #ifdef MOMENT
7627         s1=dipderg(1,jj,i)*dip(1,kk,k)
7628 #endif
7629         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7630         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7631         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7632         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7633 #ifdef MOMENT
7634         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7635 #else
7636         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7637 #endif
7638 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7639       endif
7640 C Derivatives in gamma(k-1)
7641 #ifdef MOMENT
7642       s1=dip(1,jj,i)*dipderg(1,kk,k)
7643 #endif
7644       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7645       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7646       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7647       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7648       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7649       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7650       vv(1)=pizda(1,1)-pizda(2,2)
7651       vv(2)=pizda(1,2)+pizda(2,1)
7652       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7653 #ifdef MOMENT
7654       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7655 #else
7656       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7657 #endif
7658 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7659 C Derivatives in gamma(j-1) or gamma(l-1)
7660       if (j.gt.1) then
7661 #ifdef MOMENT
7662         s1=dipderg(3,jj,i)*dip(1,kk,k)
7663 #endif
7664         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7665         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7666         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7667         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7668         vv(1)=pizda(1,1)-pizda(2,2)
7669         vv(2)=pizda(1,2)+pizda(2,1)
7670         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7671 #ifdef MOMENT
7672         if (swap) then
7673           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7674         else
7675           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7676         endif
7677 #endif
7678         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7679 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7680       endif
7681 C Derivatives in gamma(l-1) or gamma(j-1)
7682       if (l.gt.1) then
7683 #ifdef MOMENT
7684         s1=dip(1,jj,i)*dipderg(3,kk,k)
7685 #endif
7686         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7687         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7688         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7689         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7690         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7691         vv(1)=pizda(1,1)-pizda(2,2)
7692         vv(2)=pizda(1,2)+pizda(2,1)
7693         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7694 #ifdef MOMENT
7695         if (swap) then
7696           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7697         else
7698           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7699         endif
7700 #endif
7701         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7702 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7703       endif
7704 C Cartesian derivatives.
7705       if (lprn) then
7706         write (2,*) 'In eello6_graph2'
7707         do iii=1,2
7708           write (2,*) 'iii=',iii
7709           do kkk=1,5
7710             write (2,*) 'kkk=',kkk
7711             do jjj=1,2
7712               write (2,'(3(2f10.5),5x)')
7713      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7714             enddo
7715           enddo
7716         enddo
7717       endif
7718       do iii=1,2
7719         do kkk=1,5
7720           do lll=1,3
7721 #ifdef MOMENT
7722             if (iii.eq.1) then
7723               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7724             else
7725               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7726             endif
7727 #endif
7728             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7729      &        auxvec(1))
7730             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7731             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7732      &        auxvec(1))
7733             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7734             call transpose2(EUg(1,1,k),auxmat(1,1))
7735             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7736      &        pizda(1,1))
7737             vv(1)=pizda(1,1)-pizda(2,2)
7738             vv(2)=pizda(1,2)+pizda(2,1)
7739             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7740 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7741 #ifdef MOMENT
7742             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7743 #else
7744             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7745 #endif
7746             if (swap) then
7747               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7748             else
7749               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7750             endif
7751           enddo
7752         enddo
7753       enddo
7754       return
7755       end
7756 c----------------------------------------------------------------------------
7757       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7758       implicit real*8 (a-h,o-z)
7759       include 'DIMENSIONS'
7760       include 'DIMENSIONS.ZSCOPT'
7761       include 'COMMON.IOUNITS'
7762       include 'COMMON.CHAIN'
7763       include 'COMMON.DERIV'
7764       include 'COMMON.INTERACT'
7765       include 'COMMON.CONTACTS'
7766       include 'COMMON.TORSION'
7767       include 'COMMON.VAR'
7768       include 'COMMON.GEO'
7769       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7770       logical swap
7771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7772 C                                                                              C
7773 C      Parallel       Antiparallel                                             C
7774 C                                                                              C
7775 C          o             o                                                     C
7776 C         /l\   /   \   /j\                                                    C
7777 C        /   \ /     \ /   \                                                   C
7778 C       /| o |o       o| o |\                                                  C
7779 C       j|/k\|  /      |/k\|l /                                                C
7780 C        /   \ /       /   \ /                                                 C
7781 C       /     o       /     o                                                  C
7782 C       i             i                                                        C
7783 C                                                                              C
7784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7785 C
7786 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7787 C           energy moment and not to the cluster cumulant.
7788       iti=itortyp(itype(i))
7789       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7790         itj1=itortyp(itype(j+1))
7791       else
7792         itj1=ntortyp+1
7793       endif
7794       itk=itortyp(itype(k))
7795       itk1=itortyp(itype(k+1))
7796       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7797         itl1=itortyp(itype(l+1))
7798       else
7799         itl1=ntortyp+1
7800       endif
7801 #ifdef MOMENT
7802       s1=dip(4,jj,i)*dip(4,kk,k)
7803 #endif
7804       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7805       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7806       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7807       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7808       call transpose2(EE(1,1,itk),auxmat(1,1))
7809       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7810       vv(1)=pizda(1,1)+pizda(2,2)
7811       vv(2)=pizda(2,1)-pizda(1,2)
7812       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7813 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7814 #ifdef MOMENT
7815       eello6_graph3=-(s1+s2+s3+s4)
7816 #else
7817       eello6_graph3=-(s2+s3+s4)
7818 #endif
7819 c      eello6_graph3=-s4
7820       if (.not. calc_grad) return
7821 C Derivatives in gamma(k-1)
7822       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7823       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7824       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7825       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7826 C Derivatives in gamma(l-1)
7827       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7828       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7829       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7830       vv(1)=pizda(1,1)+pizda(2,2)
7831       vv(2)=pizda(2,1)-pizda(1,2)
7832       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7833       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7834 C Cartesian derivatives.
7835       do iii=1,2
7836         do kkk=1,5
7837           do lll=1,3
7838 #ifdef MOMENT
7839             if (iii.eq.1) then
7840               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7841             else
7842               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7843             endif
7844 #endif
7845             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7846      &        auxvec(1))
7847             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7848             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7849      &        auxvec(1))
7850             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7851             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7852      &        pizda(1,1))
7853             vv(1)=pizda(1,1)+pizda(2,2)
7854             vv(2)=pizda(2,1)-pizda(1,2)
7855             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7856 #ifdef MOMENT
7857             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7858 #else
7859             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7860 #endif
7861             if (swap) then
7862               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7863             else
7864               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7865             endif
7866 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7867           enddo
7868         enddo
7869       enddo
7870       return
7871       end
7872 c----------------------------------------------------------------------------
7873       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7874       implicit real*8 (a-h,o-z)
7875       include 'DIMENSIONS'
7876       include 'DIMENSIONS.ZSCOPT'
7877       include 'COMMON.IOUNITS'
7878       include 'COMMON.CHAIN'
7879       include 'COMMON.DERIV'
7880       include 'COMMON.INTERACT'
7881       include 'COMMON.CONTACTS'
7882       include 'COMMON.TORSION'
7883       include 'COMMON.VAR'
7884       include 'COMMON.GEO'
7885       include 'COMMON.FFIELD'
7886       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7887      & auxvec1(2),auxmat1(2,2)
7888       logical swap
7889 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7890 C                                                                              C
7891 C      Parallel       Antiparallel                                             C
7892 C                                                                              C
7893 C          o             o                                                     C
7894 C         /l\   /   \   /j\                                                    C
7895 C        /   \ /     \ /   \                                                   C
7896 C       /| o |o       o| o |\                                                  C
7897 C     \ j|/k\|      \  |/k\|l                                                  C
7898 C      \ /   \       \ /   \                                                   C
7899 C       o     \       o     \                                                  C
7900 C       i             i                                                        C
7901 C                                                                              C
7902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7903 C
7904 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7905 C           energy moment and not to the cluster cumulant.
7906 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7907       iti=itortyp(itype(i))
7908       itj=itortyp(itype(j))
7909       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7910         itj1=itortyp(itype(j+1))
7911       else
7912         itj1=ntortyp+1
7913       endif
7914       itk=itortyp(itype(k))
7915       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7916         itk1=itortyp(itype(k+1))
7917       else
7918         itk1=ntortyp+1
7919       endif
7920       itl=itortyp(itype(l))
7921       if (l.lt.nres-1) then
7922         itl1=itortyp(itype(l+1))
7923       else
7924         itl1=ntortyp+1
7925       endif
7926 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7927 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7928 cd     & ' itl',itl,' itl1',itl1
7929 #ifdef MOMENT
7930       if (imat.eq.1) then
7931         s1=dip(3,jj,i)*dip(3,kk,k)
7932       else
7933         s1=dip(2,jj,j)*dip(2,kk,l)
7934       endif
7935 #endif
7936       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7937       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7938       if (j.eq.l+1) then
7939         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7940         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7941       else
7942         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7943         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7944       endif
7945       call transpose2(EUg(1,1,k),auxmat(1,1))
7946       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7947       vv(1)=pizda(1,1)-pizda(2,2)
7948       vv(2)=pizda(2,1)+pizda(1,2)
7949       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7950 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7951 #ifdef MOMENT
7952       eello6_graph4=-(s1+s2+s3+s4)
7953 #else
7954       eello6_graph4=-(s2+s3+s4)
7955 #endif
7956       if (.not. calc_grad) return
7957 C Derivatives in gamma(i-1)
7958       if (i.gt.1) then
7959 #ifdef MOMENT
7960         if (imat.eq.1) then
7961           s1=dipderg(2,jj,i)*dip(3,kk,k)
7962         else
7963           s1=dipderg(4,jj,j)*dip(2,kk,l)
7964         endif
7965 #endif
7966         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7967         if (j.eq.l+1) then
7968           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7969           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7970         else
7971           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7972           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7973         endif
7974         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7975         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7976 cd          write (2,*) 'turn6 derivatives'
7977 #ifdef MOMENT
7978           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7979 #else
7980           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7981 #endif
7982         else
7983 #ifdef MOMENT
7984           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7985 #else
7986           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7987 #endif
7988         endif
7989       endif
7990 C Derivatives in gamma(k-1)
7991 #ifdef MOMENT
7992       if (imat.eq.1) then
7993         s1=dip(3,jj,i)*dipderg(2,kk,k)
7994       else
7995         s1=dip(2,jj,j)*dipderg(4,kk,l)
7996       endif
7997 #endif
7998       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7999       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8000       if (j.eq.l+1) then
8001         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8002         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8003       else
8004         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8005         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8006       endif
8007       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8008       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8009       vv(1)=pizda(1,1)-pizda(2,2)
8010       vv(2)=pizda(2,1)+pizda(1,2)
8011       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8012       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8013 #ifdef MOMENT
8014         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8015 #else
8016         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8017 #endif
8018       else
8019 #ifdef MOMENT
8020         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8021 #else
8022         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8023 #endif
8024       endif
8025 C Derivatives in gamma(j-1) or gamma(l-1)
8026       if (l.eq.j+1 .and. l.gt.1) then
8027         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8028         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8029         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8030         vv(1)=pizda(1,1)-pizda(2,2)
8031         vv(2)=pizda(2,1)+pizda(1,2)
8032         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8033         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8034       else if (j.gt.1) then
8035         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8036         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8037         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8038         vv(1)=pizda(1,1)-pizda(2,2)
8039         vv(2)=pizda(2,1)+pizda(1,2)
8040         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8041         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8042           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8043         else
8044           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8045         endif
8046       endif
8047 C Cartesian derivatives.
8048       do iii=1,2
8049         do kkk=1,5
8050           do lll=1,3
8051 #ifdef MOMENT
8052             if (iii.eq.1) then
8053               if (imat.eq.1) then
8054                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8055               else
8056                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8057               endif
8058             else
8059               if (imat.eq.1) then
8060                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8061               else
8062                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8063               endif
8064             endif
8065 #endif
8066             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8067      &        auxvec(1))
8068             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8069             if (j.eq.l+1) then
8070               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8071      &          b1(1,itj1),auxvec(1))
8072               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8073             else
8074               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8075      &          b1(1,itl1),auxvec(1))
8076               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8077             endif
8078             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8079      &        pizda(1,1))
8080             vv(1)=pizda(1,1)-pizda(2,2)
8081             vv(2)=pizda(2,1)+pizda(1,2)
8082             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8083             if (swap) then
8084               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8085 #ifdef MOMENT
8086                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8087      &             -(s1+s2+s4)
8088 #else
8089                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8090      &             -(s2+s4)
8091 #endif
8092                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8093               else
8094 #ifdef MOMENT
8095                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8096 #else
8097                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8098 #endif
8099                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8100               endif
8101             else
8102 #ifdef MOMENT
8103               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8104 #else
8105               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8106 #endif
8107               if (l.eq.j+1) then
8108                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8109               else
8110                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8111               endif
8112             endif
8113           enddo
8114         enddo
8115       enddo
8116       return
8117       end
8118 c----------------------------------------------------------------------------
8119       double precision function eello_turn6(i,jj,kk)
8120       implicit real*8 (a-h,o-z)
8121       include 'DIMENSIONS'
8122       include 'DIMENSIONS.ZSCOPT'
8123       include 'COMMON.IOUNITS'
8124       include 'COMMON.CHAIN'
8125       include 'COMMON.DERIV'
8126       include 'COMMON.INTERACT'
8127       include 'COMMON.CONTACTS'
8128       include 'COMMON.TORSION'
8129       include 'COMMON.VAR'
8130       include 'COMMON.GEO'
8131       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8132      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8133      &  ggg1(3),ggg2(3)
8134       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8135      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8136 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8137 C           the respective energy moment and not to the cluster cumulant.
8138       eello_turn6=0.0d0
8139       j=i+4
8140       k=i+1
8141       l=i+3
8142       iti=itortyp(itype(i))
8143       itk=itortyp(itype(k))
8144       itk1=itortyp(itype(k+1))
8145       itl=itortyp(itype(l))
8146       itj=itortyp(itype(j))
8147 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8148 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8149 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8150 cd        eello6=0.0d0
8151 cd        return
8152 cd      endif
8153 cd      write (iout,*)
8154 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8155 cd     &   ' and',k,l
8156 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8157       do iii=1,2
8158         do kkk=1,5
8159           do lll=1,3
8160             derx_turn(lll,kkk,iii)=0.0d0
8161           enddo
8162         enddo
8163       enddo
8164 cd      eij=1.0d0
8165 cd      ekl=1.0d0
8166 cd      ekont=1.0d0
8167       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8168 cd      eello6_5=0.0d0
8169 cd      write (2,*) 'eello6_5',eello6_5
8170 #ifdef MOMENT
8171       call transpose2(AEA(1,1,1),auxmat(1,1))
8172       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8173       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8174       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8175 #else
8176       s1 = 0.0d0
8177 #endif
8178       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8179       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8180       s2 = scalar2(b1(1,itk),vtemp1(1))
8181 #ifdef MOMENT
8182       call transpose2(AEA(1,1,2),atemp(1,1))
8183       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8184       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8185       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8186 #else
8187       s8=0.0d0
8188 #endif
8189       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8190       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8191       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8192 #ifdef MOMENT
8193       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8194       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8195       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8196       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8197       ss13 = scalar2(b1(1,itk),vtemp4(1))
8198       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8199 #else
8200       s13=0.0d0
8201 #endif
8202 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8203 c      s1=0.0d0
8204 c      s2=0.0d0
8205 c      s8=0.0d0
8206 c      s12=0.0d0
8207 c      s13=0.0d0
8208       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8209       if (calc_grad) then
8210 C Derivatives in gamma(i+2)
8211 #ifdef MOMENT
8212       call transpose2(AEA(1,1,1),auxmatd(1,1))
8213       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8214       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8215       call transpose2(AEAderg(1,1,2),atempd(1,1))
8216       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8217       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8218 #else
8219       s8d=0.0d0
8220 #endif
8221       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8222       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8223       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8224 c      s1d=0.0d0
8225 c      s2d=0.0d0
8226 c      s8d=0.0d0
8227 c      s12d=0.0d0
8228 c      s13d=0.0d0
8229       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8230 C Derivatives in gamma(i+3)
8231 #ifdef MOMENT
8232       call transpose2(AEA(1,1,1),auxmatd(1,1))
8233       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8234       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8235       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8236 #else
8237       s1d=0.0d0
8238 #endif
8239       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8240       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8241       s2d = scalar2(b1(1,itk),vtemp1d(1))
8242 #ifdef MOMENT
8243       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8244       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8245 #endif
8246       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8247 #ifdef MOMENT
8248       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8249       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8250       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8251 #else
8252       s13d=0.0d0
8253 #endif
8254 c      s1d=0.0d0
8255 c      s2d=0.0d0
8256 c      s8d=0.0d0
8257 c      s12d=0.0d0
8258 c      s13d=0.0d0
8259 #ifdef MOMENT
8260       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8261      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8262 #else
8263       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8264      &               -0.5d0*ekont*(s2d+s12d)
8265 #endif
8266 C Derivatives in gamma(i+4)
8267       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8268       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8269       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8270 #ifdef MOMENT
8271       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8272       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8273       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8274 #else
8275       s13d = 0.0d0
8276 #endif
8277 c      s1d=0.0d0
8278 c      s2d=0.0d0
8279 c      s8d=0.0d0
8280 C      s12d=0.0d0
8281 c      s13d=0.0d0
8282 #ifdef MOMENT
8283       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8284 #else
8285       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8286 #endif
8287 C Derivatives in gamma(i+5)
8288 #ifdef MOMENT
8289       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8290       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8291       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8292 #else
8293       s1d = 0.0d0
8294 #endif
8295       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8296       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8297       s2d = scalar2(b1(1,itk),vtemp1d(1))
8298 #ifdef MOMENT
8299       call transpose2(AEA(1,1,2),atempd(1,1))
8300       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8301       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8302 #else
8303       s8d = 0.0d0
8304 #endif
8305       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8306       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8307 #ifdef MOMENT
8308       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8309       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8310       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8311 #else
8312       s13d = 0.0d0
8313 #endif
8314 c      s1d=0.0d0
8315 c      s2d=0.0d0
8316 c      s8d=0.0d0
8317 c      s12d=0.0d0
8318 c      s13d=0.0d0
8319 #ifdef MOMENT
8320       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8321      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8322 #else
8323       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8324      &               -0.5d0*ekont*(s2d+s12d)
8325 #endif
8326 C Cartesian derivatives
8327       do iii=1,2
8328         do kkk=1,5
8329           do lll=1,3
8330 #ifdef MOMENT
8331             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8332             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8333             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8334 #else
8335             s1d = 0.0d0
8336 #endif
8337             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8338             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8339      &          vtemp1d(1))
8340             s2d = scalar2(b1(1,itk),vtemp1d(1))
8341 #ifdef MOMENT
8342             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8343             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8344             s8d = -(atempd(1,1)+atempd(2,2))*
8345      &           scalar2(cc(1,1,itl),vtemp2(1))
8346 #else
8347             s8d = 0.0d0
8348 #endif
8349             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8350      &           auxmatd(1,1))
8351             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8352             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8353 c      s1d=0.0d0
8354 c      s2d=0.0d0
8355 c      s8d=0.0d0
8356 c      s12d=0.0d0
8357 c      s13d=0.0d0
8358 #ifdef MOMENT
8359             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8360      &        - 0.5d0*(s1d+s2d)
8361 #else
8362             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8363      &        - 0.5d0*s2d
8364 #endif
8365 #ifdef MOMENT
8366             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8367      &        - 0.5d0*(s8d+s12d)
8368 #else
8369             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8370      &        - 0.5d0*s12d
8371 #endif
8372           enddo
8373         enddo
8374       enddo
8375 #ifdef MOMENT
8376       do kkk=1,5
8377         do lll=1,3
8378           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8379      &      achuj_tempd(1,1))
8380           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8381           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8382           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8383           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8384           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8385      &      vtemp4d(1))
8386           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8387           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8388           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8389         enddo
8390       enddo
8391 #endif
8392 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8393 cd     &  16*eel_turn6_num
8394 cd      goto 1112
8395       if (j.lt.nres-1) then
8396         j1=j+1
8397         j2=j-1
8398       else
8399         j1=j-1
8400         j2=j-2
8401       endif
8402       if (l.lt.nres-1) then
8403         l1=l+1
8404         l2=l-1
8405       else
8406         l1=l-1
8407         l2=l-2
8408       endif
8409       do ll=1,3
8410         ggg1(ll)=eel_turn6*g_contij(ll,1)
8411         ggg2(ll)=eel_turn6*g_contij(ll,2)
8412         ghalf=0.5d0*ggg1(ll)
8413 cd        ghalf=0.0d0
8414         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8415      &    +ekont*derx_turn(ll,2,1)
8416         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8417         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8418      &    +ekont*derx_turn(ll,4,1)
8419         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8420         ghalf=0.5d0*ggg2(ll)
8421 cd        ghalf=0.0d0
8422         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8423      &    +ekont*derx_turn(ll,2,2)
8424         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8425         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8426      &    +ekont*derx_turn(ll,4,2)
8427         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8428       enddo
8429 cd      goto 1112
8430       do m=i+1,j-1
8431         do ll=1,3
8432           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8433         enddo
8434       enddo
8435       do m=k+1,l-1
8436         do ll=1,3
8437           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8438         enddo
8439       enddo
8440 1112  continue
8441       do m=i+2,j2
8442         do ll=1,3
8443           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8444         enddo
8445       enddo
8446       do m=k+2,l2
8447         do ll=1,3
8448           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8449         enddo
8450       enddo
8451 cd      do iii=1,nres-3
8452 cd        write (2,*) iii,g_corr6_loc(iii)
8453 cd      enddo
8454       endif
8455       eello_turn6=ekont*eel_turn6
8456 cd      write (2,*) 'ekont',ekont
8457 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8458       return
8459       end
8460 crc-------------------------------------------------
8461       SUBROUTINE MATVEC2(A1,V1,V2)
8462       implicit real*8 (a-h,o-z)
8463       include 'DIMENSIONS'
8464       DIMENSION A1(2,2),V1(2),V2(2)
8465 c      DO 1 I=1,2
8466 c        VI=0.0
8467 c        DO 3 K=1,2
8468 c    3     VI=VI+A1(I,K)*V1(K)
8469 c        Vaux(I)=VI
8470 c    1 CONTINUE
8471
8472       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8473       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8474
8475       v2(1)=vaux1
8476       v2(2)=vaux2
8477       END
8478 C---------------------------------------
8479       SUBROUTINE MATMAT2(A1,A2,A3)
8480       implicit real*8 (a-h,o-z)
8481       include 'DIMENSIONS'
8482       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8483 c      DIMENSION AI3(2,2)
8484 c        DO  J=1,2
8485 c          A3IJ=0.0
8486 c          DO K=1,2
8487 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8488 c          enddo
8489 c          A3(I,J)=A3IJ
8490 c       enddo
8491 c      enddo
8492
8493       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8494       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8495       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8496       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8497
8498       A3(1,1)=AI3_11
8499       A3(2,1)=AI3_21
8500       A3(1,2)=AI3_12
8501       A3(2,2)=AI3_22
8502       END
8503
8504 c-------------------------------------------------------------------------
8505       double precision function scalar2(u,v)
8506       implicit none
8507       double precision u(2),v(2)
8508       double precision sc
8509       integer i
8510       scalar2=u(1)*v(1)+u(2)*v(2)
8511       return
8512       end
8513
8514 C-----------------------------------------------------------------------------
8515
8516       subroutine transpose2(a,at)
8517       implicit none
8518       double precision a(2,2),at(2,2)
8519       at(1,1)=a(1,1)
8520       at(1,2)=a(2,1)
8521       at(2,1)=a(1,2)
8522       at(2,2)=a(2,2)
8523       return
8524       end
8525 c--------------------------------------------------------------------------
8526       subroutine transpose(n,a,at)
8527       implicit none
8528       integer n,i,j
8529       double precision a(n,n),at(n,n)
8530       do i=1,n
8531         do j=1,n
8532           at(j,i)=a(i,j)
8533         enddo
8534       enddo
8535       return
8536       end
8537 C---------------------------------------------------------------------------
8538       subroutine prodmat3(a1,a2,kk,transp,prod)
8539       implicit none
8540       integer i,j
8541       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8542       logical transp
8543 crc      double precision auxmat(2,2),prod_(2,2)
8544
8545       if (transp) then
8546 crc        call transpose2(kk(1,1),auxmat(1,1))
8547 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8548 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8549
8550            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8551      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8552            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8553      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8554            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8555      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8556            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8557      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8558
8559       else
8560 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8561 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8562
8563            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8564      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8565            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8566      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8567            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8568      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8569            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8570      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8571
8572       endif
8573 c      call transpose2(a2(1,1),a2t(1,1))
8574
8575 crc      print *,transp
8576 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8577 crc      print *,((prod(i,j),i=1,2),j=1,2)
8578
8579       return
8580       end
8581 C-----------------------------------------------------------------------------
8582       double precision function scalar(u,v)
8583       implicit none
8584       double precision u(3),v(3)
8585       double precision sc
8586       integer i
8587       sc=0.0d0
8588       do i=1,3
8589         sc=sc+u(i)*v(i)
8590       enddo
8591       scalar=sc
8592       return
8593       end
8594 C-----------------------------------------------------------------------
8595       double precision function sscale(r)
8596       double precision r,gamm
8597       include "COMMON.SPLITELE"
8598       if(r.lt.r_cut-rlamb) then
8599         sscale=1.0d0
8600       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8601         gamm=(r-(r_cut-rlamb))/rlamb
8602         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8603       else
8604         sscale=0d0
8605       endif
8606       return
8607       end
8608 C-----------------------------------------------------------------------
8609 C-----------------------------------------------------------------------
8610       double precision function sscagrad(r)
8611       double precision r,gamm
8612       include "COMMON.SPLITELE"
8613       if(r.lt.r_cut-rlamb) then
8614         sscagrad=0.0d0
8615       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8616         gamm=(r-(r_cut-rlamb))/rlamb
8617         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8618       else
8619         sscagrad=0.0d0
8620       endif
8621       return
8622       end
8623 C-----------------------------------------------------------------------
8624 C-----------------------------------------------------------------------
8625       double precision function sscalelip(r)
8626       double precision r,gamm
8627       include "COMMON.SPLITELE"
8628 C      if(r.lt.r_cut-rlamb) then
8629 C        sscale=1.0d0
8630 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8631 C        gamm=(r-(r_cut-rlamb))/rlamb
8632         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8633 C      else
8634 C        sscale=0d0
8635 C      endif
8636       return
8637       end
8638 C-----------------------------------------------------------------------
8639       double precision function sscagradlip(r)
8640       double precision r,gamm
8641       include "COMMON.SPLITELE"
8642 C     if(r.lt.r_cut-rlamb) then
8643 C        sscagrad=0.0d0
8644 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8645 C        gamm=(r-(r_cut-rlamb))/rlamb
8646         sscagradlip=r*(6*r-6.0d0)
8647 C      else
8648 C        sscagrad=0.0d0
8649 C      endif
8650       return
8651       end
8652