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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  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 continue
  53       write(iout,*) "shield_mode",shield_mode,ethetacnstr
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68       call ebond(estr)
  69 c      write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79       call ebend(ebe,ethetacnstr)
  80 cd    print *,'Bend energy finished.'
  81 C
  82 C Calculate the SC local energy.
  83 C
  84       call esc(escloc)
  85 cd    print *,'SCLOC energy finished.'
  86 C
  87 C Calculate the virtual-bond torsional energy.
  88 C
  89 cd    print *,'nterm=',nterm
  90       call etor(etors,edihcnstr,fact(1))
  91 C
  92 C 6/23/01 Calculate double-torsional energy
  93 C
  94       call etor_d(etors_d,fact(2))
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99 C
 100 C 12/1/95 Multi-body terms
 101 C
 102       n_corr=0
 103       n_corr1=0
 104       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 105      &    .or. wturn6.gt.0.0d0) then
 106 c         print *,"calling multibody_eello"
 107          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 108 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 109 c         print *,ecorr,ecorr5,ecorr6,eturn6
 110       endif
 111       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 112          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 113       endif
 114       write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 115 #ifdef SPLITELE
 116       if (shield_mode.gt.0) then
 117       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 118      & +welec*fact(1)*ees
 119      & +fact(1)*wvdwpp*evdw1
 120      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 121      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 122      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 123      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 124      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 125      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 126 C     & +wliptran*eliptran
 127       else
 128       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 129      & +wvdwpp*evdw1
 130      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 131      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 132      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 133      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 134      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 135      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 136 C     & +wliptran*eliptran
 137       endif
 138 #else
 139       if (shield_mode.gt.0) then
 140       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 141      & +welec*fact(1)*(ees+evdw1)
 142      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 143      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 144      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 145      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 146      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 147      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 148 C     & +wliptran*eliptran
 149       else
 150       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 151      & +welec*fact(1)*(ees+evdw1)
 152      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 153      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 154      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 155      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 156      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 157      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 158 C     & +wliptran*eliptran
 159       endif
 160 #endif
 161
 162       energia(0)=etot
 163       energia(1)=evdw
 164 #ifdef SCP14
 165       energia(2)=evdw2-evdw2_14
 166       energia(17)=evdw2_14
 167 #else
 168       energia(2)=evdw2
 169       energia(17)=0.0d0
 170 #endif
 171 #ifdef SPLITELE
 172       energia(3)=ees
 173       energia(16)=evdw1
 174 #else
 175       energia(3)=ees+evdw1
 176       energia(16)=0.0d0
 177 #endif
 178       energia(4)=ecorr
 179       energia(5)=ecorr5
 180       energia(6)=ecorr6
 181       energia(7)=eel_loc
 182       energia(8)=eello_turn3
 183       energia(9)=eello_turn4
 184       energia(10)=eturn6
 185       energia(11)=ebe
 186       energia(12)=escloc
 187       energia(13)=etors
 188       energia(14)=etors_d
 189       energia(15)=ehpb
 190       energia(18)=estr
 191       energia(19)=esccor
 192       energia(20)=edihcnstr
 193       energia(21)=evdw_t
 194       energia(24)=ethetacnstr
 195 c detecting NaNQ
 196 #ifdef ISNAN
 197 #ifdef AIX
 198       if (isnan(etot).ne.0) energia(0)=1.0d+99
 199 #else
 200       if (isnan(etot)) energia(0)=1.0d+99
 201 #endif
 202 #else
 203       i=0
 204 #ifdef WINPGI
 205       idumm=proc_proc(etot,i)
 206 #else
 207       call proc_proc(etot,i)
 208 #endif
 209       if(i.eq.1)energia(0)=1.0d+99
 210 #endif
 211 #ifdef MPL
 212 c     endif
 213 #endif
 214       if (calc_grad) then
 215 C
 216 C Sum up the components of the Cartesian gradient.
 217 C
 218 #ifdef SPLITELE
 219       do i=1,nct
 220         do j=1,3
 221       if (shield_mode.eq.0) then
 222           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 223      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 224      &                wbond*gradb(j,i)+
 225      &                wstrain*ghpbc(j,i)+
 226      &                wcorr*fact(3)*gradcorr(j,i)+
 227      &                wel_loc*fact(2)*gel_loc(j,i)+
 228      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 229      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 230      &                wcorr5*fact(4)*gradcorr5(j,i)+
 231      &                wcorr6*fact(5)*gradcorr6(j,i)+
 232      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 233      &                wsccor*fact(2)*gsccorc(j,i)
 234      &               +wliptran*gliptranc(j,i)
 235           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 236      &                  wbond*gradbx(j,i)+
 237      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 238      &                  wsccor*fact(2)*gsccorx(j,i)
 239      &                 +wliptran*gliptranx(j,i)
 240         else
 241           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 242      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 243      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 244      &                wbond*gradb(j,i)+
 245      &                wstrain*ghpbc(j,i)+
 246      &                wcorr*fact(3)*gradcorr(j,i)+
 247      &                wel_loc*fact(2)*gel_loc(j,i)+
 248      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 249      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 250      &                wcorr5*fact(4)*gradcorr5(j,i)+
 251      &                wcorr6*fact(5)*gradcorr6(j,i)+
 252      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 253      &                wsccor*fact(2)*gsccorc(j,i)
 254      &               +wliptran*gliptranc(j,i)
 255      &                 +welec*gshieldc(j,i)
 256      &                 +welec*gshieldc_loc(j,i)
 257      &                 +wcorr*gshieldc_ec(j,i)
 258      &                 +wcorr*gshieldc_loc_ec(j,i)
 259      &                 +wturn3*gshieldc_t3(j,i)
 260      &                 +wturn3*gshieldc_loc_t3(j,i)
 261      &                 +wturn4*gshieldc_t4(j,i)
 262      &                 +wturn4*gshieldc_loc_t4(j,i)
 263      &                 +wel_loc*gshieldc_ll(j,i)
 264      &                 +wel_loc*gshieldc_loc_ll(j,i)
 265
 266           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 267      &                 +fact(1)*wscp*gradx_scp(j,i)+
 268      &                  wbond*gradbx(j,i)+
 269      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 270      &                  wsccor*fact(2)*gsccorx(j,i)
 271      &                 +wliptran*gliptranx(j,i)
 272      &                 +welec*gshieldx(j,i)
 273      &                 +wcorr*gshieldx_ec(j,i)
 274      &                 +wturn3*gshieldx_t3(j,i)
 275      &                 +wturn4*gshieldx_t4(j,i)
 276      &                 +wel_loc*gshieldx_ll(j,i)
 277
 278
 279         endif
 280         enddo
 281 #else
 282        do i=1,nct
 283         do j=1,3
 284                 if (shield_mode.eq.0) then
 285           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 286      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 287      &                wbond*gradb(j,i)+
 288      &                wcorr*fact(3)*gradcorr(j,i)+
 289      &                wel_loc*fact(2)*gel_loc(j,i)+
 290      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 291      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 292      &                wcorr5*fact(4)*gradcorr5(j,i)+
 293      &                wcorr6*fact(5)*gradcorr6(j,i)+
 294      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 295      &                wsccor*fact(2)*gsccorc(j,i)
 296      &               +wliptran*gliptranc(j,i)
 297           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 298      &                  wbond*gradbx(j,i)+
 299      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 300      &                  wsccor*fact(1)*gsccorx(j,i)
 301      &                 +wliptran*gliptranx(j,i)
 302               else
 303           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 304      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 305      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 306      &                wbond*gradb(j,i)+
 307      &                wcorr*fact(3)*gradcorr(j,i)+
 308      &                wel_loc*fact(2)*gel_loc(j,i)+
 309      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 310      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 311      &                wcorr5*fact(4)*gradcorr5(j,i)+
 312      &                wcorr6*fact(5)*gradcorr6(j,i)+
 313      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 314      &                wsccor*fact(2)*gsccorc(j,i)
 315      &               +wliptran*gliptranc(j,i)
 316           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 317      &                  fact(1)*wscp*gradx_scp(j,i)+
 318      &                  wbond*gradbx(j,i)+
 319      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 320      &                  wsccor*fact(1)*gsccorx(j,i)
 321      &                 +wliptran*gliptranx(j,i)
 322          endif
 323         enddo
 324 #endif
 325       enddo
 326
 327
 328       do i=1,nres-3
 329         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 330      &   +wcorr5*fact(4)*g_corr5_loc(i)
 331      &   +wcorr6*fact(5)*g_corr6_loc(i)
 332      &   +wturn4*fact(3)*gel_loc_turn4(i)
 333      &   +wturn3*fact(2)*gel_loc_turn3(i)
 334      &   +wturn6*fact(5)*gel_loc_turn6(i)
 335      &   +wel_loc*fact(2)*gel_loc_loc(i)
 336 c     &   +wsccor*fact(1)*gsccor_loc(i)
 337 c ROZNICA Z WHAMem
 338       enddo
 339       endif
 340       if (dyn_ss) call dyn_set_nss
 341       return
 342       end
 343 C------------------------------------------------------------------------
 344       subroutine enerprint(energia,fact)
 345       implicit real*8 (a-h,o-z)
 346       include 'DIMENSIONS'
 347       include 'sizesclu.dat'
 348       include 'COMMON.IOUNITS'
 349       include 'COMMON.FFIELD'
 350       include 'COMMON.SBRIDGE'
 351       double precision energia(0:max_ene),fact(6)
 352       etot=energia(0)
 353       evdw=energia(1)+fact(6)*energia(21)
 354 #ifdef SCP14
 355       evdw2=energia(2)+energia(17)
 356 #else
 357       evdw2=energia(2)
 358 #endif
 359       ees=energia(3)
 360 #ifdef SPLITELE
 361       evdw1=energia(16)
 362 #endif
 363       ecorr=energia(4)
 364       ecorr5=energia(5)
 365       ecorr6=energia(6)
 366       eel_loc=energia(7)
 367       eello_turn3=energia(8)
 368       eello_turn4=energia(9)
 369       eello_turn6=energia(10)
 370       ebe=energia(11)
 371       escloc=energia(12)
 372       etors=energia(13)
 373       etors_d=energia(14)
 374       ehpb=energia(15)
 375       esccor=energia(19)
 376       edihcnstr=energia(20)
 377       estr=energia(18)
 378       ethetacnstr=energia(24)
 379 #ifdef SPLITELE
 380       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 381      &  wvdwpp,
 382      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 383      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 384      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 385      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 386      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 387      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 388    10 format (/'Virtual-chain energies:'//
 389      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 390      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 391      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 392      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 393      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 394      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 395      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 396      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 397      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 398      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 399      & ' (SS bridges & dist. cnstr.)'/
 400      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 401      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 402      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 403      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 404      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 405      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 406      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 407      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 408      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 409      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 410      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 411      & 'ETOT=  ',1pE16.6,' (total)')
 412 #else
 413       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 414      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 415      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 416      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 417      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 418      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 419      &  edihcnstr,ethetacnstr,ebr*nss,etot
 420    10 format (/'Virtual-chain energies:'//
 421      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 422      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 423      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 424      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 425      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 426      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 427      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 428      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 429      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 430      & ' (SS bridges & dist. cnstr.)'/
 431      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 432      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 433      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 434      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 435      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 436      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 437      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 438      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 439      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 440      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 441      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 442      & 'ETOT=  ',1pE16.6,' (total)')
 443 #endif
 444       return
 445       end
 446 C-----------------------------------------------------------------------
 447       subroutine elj(evdw,evdw_t)
 448 C
 449 C This subroutine calculates the interaction energy of nonbonded side chains
 450 C assuming the LJ potential of interaction.
 451 C
 452       implicit real*8 (a-h,o-z)
 453       include 'DIMENSIONS'
 454       include 'sizesclu.dat'
 455       include "DIMENSIONS.COMPAR"
 456       parameter (accur=1.0d-10)
 457       include 'COMMON.GEO'
 458       include 'COMMON.VAR'
 459       include 'COMMON.LOCAL'
 460       include 'COMMON.CHAIN'
 461       include 'COMMON.DERIV'
 462       include 'COMMON.INTERACT'
 463       include 'COMMON.TORSION'
 464       include 'COMMON.SBRIDGE'
 465       include 'COMMON.NAMES'
 466       include 'COMMON.IOUNITS'
 467       include 'COMMON.CONTACTS'
 468       dimension gg(3)
 469       integer icant
 470       external icant
 471 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 472 c ROZNICA DODANE Z WHAM
 473 c      do i=1,210
 474 c        do j=1,2
 475 c          eneps_temp(j,i)=0.0d0
 476 c        enddo
 477 c      enddo
 478 cROZNICA
 479
 480       evdw=0.0D0
 481       evdw_t=0.0d0
 482       do i=iatsc_s,iatsc_e
 483         itypi=iabs(itype(i))
 484         if (itypi.eq.ntyp1) cycle
 485         itypi1=iabs(itype(i+1))
 486         xi=c(1,nres+i)
 487         yi=c(2,nres+i)
 488         zi=c(3,nres+i)
 489 C Change 12/1/95
 490         num_conti=0
 491 C
 492 C Calculate SC interaction energy.
 493 C
 494         do iint=1,nint_gr(i)
 495 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 496 cd   &                  'iend=',iend(i,iint)
 497           do j=istart(i,iint),iend(i,iint)
 498             itypj=iabs(itype(j))
 499             if (itypj.eq.ntyp1) cycle
 500             xj=c(1,nres+j)-xi
 501             yj=c(2,nres+j)-yi
 502             zj=c(3,nres+j)-zi
 503 C Change 12/1/95 to calculate four-body interactions
 504             rij=xj*xj+yj*yj+zj*zj
 505             rrij=1.0D0/rij
 506 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 507             eps0ij=eps(itypi,itypj)
 508             fac=rrij**expon2
 509             e1=fac*fac*aa(itypi,itypj)
 510             e2=fac*bb(itypi,itypj)
 511             evdwij=e1+e2
 512             ij=icant(itypi,itypj)
 513 c ROZNICA z WHAM
 514 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 515 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 516 c
 517
 518 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 519 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 520 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 521 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 522 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 523 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 524             if (bb(itypi,itypj).gt.0.0d0) then
 525               evdw=evdw+evdwij
 526             else
 527               evdw_t=evdw_t+evdwij
 528             endif
 529             if (calc_grad) then
 530 C
 531 C Calculate the components of the gradient in DC and X
 532 C
 533             fac=-rrij*(e1+evdwij)
 534             gg(1)=xj*fac
 535             gg(2)=yj*fac
 536             gg(3)=zj*fac
 537             do k=1,3
 538               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 539               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 540             enddo
 541             do k=i,j-1
 542               do l=1,3
 543                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 544               enddo
 545             enddo
 546             endif
 547 C
 548 C 12/1/95, revised on 5/20/97
 549 C
 550 C Calculate the contact function. The ith column of the array JCONT will
 551 C contain the numbers of atoms that make contacts with the atom I (of numbers
 552 C greater than I). The arrays FACONT and GACONT will contain the values of
 553 C the contact function and its derivative.
 554 C
 555 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 556 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 557 C Uncomment next line, if the correlation interactions are contact function only
 558             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 559               rij=dsqrt(rij)
 560               sigij=sigma(itypi,itypj)
 561               r0ij=rs0(itypi,itypj)
 562 C
 563 C Check whether the SC's are not too far to make a contact.
 564 C
 565               rcut=1.5d0*r0ij
 566               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 567 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 568 C
 569               if (fcont.gt.0.0D0) then
 570 C If the SC-SC distance if close to sigma, apply spline.
 571 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 572 cAdam &             fcont1,fprimcont1)
 573 cAdam           fcont1=1.0d0-fcont1
 574 cAdam           if (fcont1.gt.0.0d0) then
 575 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 576 cAdam             fcont=fcont*fcont1
 577 cAdam           endif
 578 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 579 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 580 cga             do k=1,3
 581 cga               gg(k)=gg(k)*eps0ij
 582 cga             enddo
 583 cga             eps0ij=-evdwij*eps0ij
 584 C Uncomment for AL's type of SC correlation interactions.
 585 cadam           eps0ij=-evdwij
 586                 num_conti=num_conti+1
 587                 jcont(num_conti,i)=j
 588                 facont(num_conti,i)=fcont*eps0ij
 589                 fprimcont=eps0ij*fprimcont/rij
 590                 fcont=expon*fcont
 591 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 592 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 593 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 594 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 595                 gacont(1,num_conti,i)=-fprimcont*xj
 596                 gacont(2,num_conti,i)=-fprimcont*yj
 597                 gacont(3,num_conti,i)=-fprimcont*zj
 598 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 599 cd              write (iout,'(2i3,3f10.5)')
 600 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 601               endif
 602             endif
 603           enddo      ! j
 604         enddo        ! iint
 605 C Change 12/1/95
 606         num_cont(i)=num_conti
 607       enddo          ! i
 608       if (calc_grad) then
 609       do i=1,nct
 610         do j=1,3
 611           gvdwc(j,i)=expon*gvdwc(j,i)
 612           gvdwx(j,i)=expon*gvdwx(j,i)
 613         enddo
 614       enddo
 615       endif
 616 C******************************************************************************
 617 C
 618 C                              N O T E !!!
 619 C
 620 C To save time, the factor of EXPON has been extracted from ALL components
 621 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 622 C use!
 623 C
 624 C******************************************************************************
 625       return
 626       end
 627 C-----------------------------------------------------------------------------
 628       subroutine eljk(evdw,evdw_t)
 629 C
 630 C This subroutine calculates the interaction energy of nonbonded side chains
 631 C assuming the LJK potential of interaction.
 632 C
 633       implicit real*8 (a-h,o-z)
 634       include 'DIMENSIONS'
 635       include 'sizesclu.dat'
 636       include "DIMENSIONS.COMPAR"
 637       include 'COMMON.GEO'
 638       include 'COMMON.VAR'
 639       include 'COMMON.LOCAL'
 640       include 'COMMON.CHAIN'
 641       include 'COMMON.DERIV'
 642       include 'COMMON.INTERACT'
 643       include 'COMMON.IOUNITS'
 644       include 'COMMON.NAMES'
 645       dimension gg(3)
 646       logical scheck
 647       integer icant
 648       external icant
 649 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 650       evdw=0.0D0
 651       evdw_t=0.0d0
 652       do i=iatsc_s,iatsc_e
 653         itypi=iabs(itype(i))
 654         if (itypi.eq.ntyp1) cycle
 655         itypi1=iabs(itype(i+1))
 656         xi=c(1,nres+i)
 657         yi=c(2,nres+i)
 658         zi=c(3,nres+i)
 659 C
 660 C Calculate SC interaction energy.
 661 C
 662         do iint=1,nint_gr(i)
 663           do j=istart(i,iint),iend(i,iint)
 664             itypj=iabs(itype(j))
 665             if (itypj.eq.ntyp1) cycle
 666             xj=c(1,nres+j)-xi
 667             yj=c(2,nres+j)-yi
 668             zj=c(3,nres+j)-zi
 669             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 670             fac_augm=rrij**expon
 671             e_augm=augm(itypi,itypj)*fac_augm
 672             r_inv_ij=dsqrt(rrij)
 673             rij=1.0D0/r_inv_ij
 674             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 675             fac=r_shift_inv**expon
 676             e1=fac*fac*aa(itypi,itypj)
 677             e2=fac*bb(itypi,itypj)
 678             evdwij=e_augm+e1+e2
 679             ij=icant(itypi,itypj)
 680 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 681 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 682 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 683 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 684 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 685 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 686 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 687             if (bb(itypi,itypj).gt.0.0d0) then
 688               evdw=evdw+evdwij
 689             else
 690               evdw_t=evdw_t+evdwij
 691             endif
 692             if (calc_grad) then
 693 C
 694 C Calculate the components of the gradient in DC and X
 695 C
 696             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 697             gg(1)=xj*fac
 698             gg(2)=yj*fac
 699             gg(3)=zj*fac
 700             do k=1,3
 701               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 702               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 703             enddo
 704             do k=i,j-1
 705               do l=1,3
 706                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 707               enddo
 708             enddo
 709             endif
 710           enddo      ! j
 711         enddo        ! iint
 712       enddo          ! i
 713       if (calc_grad) then
 714       do i=1,nct
 715         do j=1,3
 716           gvdwc(j,i)=expon*gvdwc(j,i)
 717           gvdwx(j,i)=expon*gvdwx(j,i)
 718         enddo
 719       enddo
 720       endif
 721       return
 722       end
 723 C-----------------------------------------------------------------------------
 724       subroutine ebp(evdw,evdw_t)
 725 C
 726 C This subroutine calculates the interaction energy of nonbonded side chains
 727 C assuming the Berne-Pechukas potential of interaction.
 728 C
 729       implicit real*8 (a-h,o-z)
 730       include 'DIMENSIONS'
 731       include 'sizesclu.dat'
 732       include "DIMENSIONS.COMPAR"
 733       include 'COMMON.GEO'
 734       include 'COMMON.VAR'
 735       include 'COMMON.LOCAL'
 736       include 'COMMON.CHAIN'
 737       include 'COMMON.DERIV'
 738       include 'COMMON.NAMES'
 739       include 'COMMON.INTERACT'
 740       include 'COMMON.IOUNITS'
 741       include 'COMMON.CALC'
 742       common /srutu/ icall
 743 c     double precision rrsave(maxdim)
 744       logical lprn
 745       integer icant
 746       external icant
 747       evdw=0.0D0
 748       evdw_t=0.0d0
 749 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 750 c     if (icall.eq.0) then
 751 c       lprn=.true.
 752 c     else
 753         lprn=.false.
 754 c     endif
 755       ind=0
 756       do i=iatsc_s,iatsc_e
 757         itypi=iabs(itype(i))
 758         if (itypi.eq.ntyp1) cycle
 759         itypi1=iabs(itype(i+1))
 760         xi=c(1,nres+i)
 761         yi=c(2,nres+i)
 762         zi=c(3,nres+i)
 763         dxi=dc_norm(1,nres+i)
 764         dyi=dc_norm(2,nres+i)
 765         dzi=dc_norm(3,nres+i)
 766         dsci_inv=vbld_inv(i+nres)
 767 C
 768 C Calculate SC interaction energy.
 769 C
 770         do iint=1,nint_gr(i)
 771           do j=istart(i,iint),iend(i,iint)
 772             ind=ind+1
 773             itypj=iabs(itype(j))
 774             if (itypj.eq.ntyp1) cycle
 775             dscj_inv=vbld_inv(j+nres)
 776             chi1=chi(itypi,itypj)
 777             chi2=chi(itypj,itypi)
 778             chi12=chi1*chi2
 779             chip1=chip(itypi)
 780             chip2=chip(itypj)
 781             chip12=chip1*chip2
 782             alf1=alp(itypi)
 783             alf2=alp(itypj)
 784             alf12=0.5D0*(alf1+alf2)
 785 C For diagnostics only!!!
 786 c           chi1=0.0D0
 787 c           chi2=0.0D0
 788 c           chi12=0.0D0
 789 c           chip1=0.0D0
 790 c           chip2=0.0D0
 791 c           chip12=0.0D0
 792 c           alf1=0.0D0
 793 c           alf2=0.0D0
 794 c           alf12=0.0D0
 795             xj=c(1,nres+j)-xi
 796             yj=c(2,nres+j)-yi
 797             zj=c(3,nres+j)-zi
 798             dxj=dc_norm(1,nres+j)
 799             dyj=dc_norm(2,nres+j)
 800             dzj=dc_norm(3,nres+j)
 801             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 802 cd          if (icall.eq.0) then
 803 cd            rrsave(ind)=rrij
 804 cd          else
 805 cd            rrij=rrsave(ind)
 806 cd          endif
 807             rij=dsqrt(rrij)
 808 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 809             call sc_angular
 810 C Calculate whole angle-dependent part of epsilon and contributions
 811 C to its derivatives
 812             fac=(rrij*sigsq)**expon2
 813             e1=fac*fac*aa(itypi,itypj)
 814             e2=fac*bb(itypi,itypj)
 815             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 816             eps2der=evdwij*eps3rt
 817             eps3der=evdwij*eps2rt
 818             evdwij=evdwij*eps2rt*eps3rt
 819             ij=icant(itypi,itypj)
 820             aux=eps1*eps2rt**2*eps3rt**2
 821             if (bb(itypi,itypj).gt.0.0d0) then
 822               evdw=evdw+evdwij
 823             else
 824               evdw_t=evdw_t+evdwij
 825             endif
 826             if (calc_grad) then
 827             if (lprn) then
 828             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 829             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 830 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 831 cd     &        restyp(itypi),i,restyp(itypj),j,
 832 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 833 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 834 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 835 cd     &        evdwij
 836             endif
 837 C Calculate gradient components.
 838             e1=e1*eps1*eps2rt**2*eps3rt**2
 839             fac=-expon*(e1+evdwij)
 840             sigder=fac/sigsq
 841             fac=rrij*fac
 842 C Calculate radial part of the gradient
 843             gg(1)=xj*fac
 844             gg(2)=yj*fac
 845             gg(3)=zj*fac
 846 C Calculate the angular part of the gradient and sum add the contributions
 847 C to the appropriate components of the Cartesian gradient.
 848             call sc_grad
 849             endif
 850           enddo      ! j
 851         enddo        ! iint
 852       enddo          ! i
 853 c     stop
 854       return
 855       end
 856 C-----------------------------------------------------------------------------
 857       subroutine egb(evdw,evdw_t)
 858 C
 859 C This subroutine calculates the interaction energy of nonbonded side chains
 860 C assuming the Gay-Berne potential of interaction.
 861 C
 862       implicit real*8 (a-h,o-z)
 863       include 'DIMENSIONS'
 864       include 'sizesclu.dat'
 865       include "DIMENSIONS.COMPAR"
 866       include 'COMMON.GEO'
 867       include 'COMMON.VAR'
 868       include 'COMMON.LOCAL'
 869       include 'COMMON.CHAIN'
 870       include 'COMMON.DERIV'
 871       include 'COMMON.NAMES'
 872       include 'COMMON.INTERACT'
 873       include 'COMMON.IOUNITS'
 874       include 'COMMON.CALC'
 875       include 'COMMON.SBRIDGE'
 876       logical lprn
 877       common /srutu/icall
 878       integer icant
 879       external icant
 880       integer xshift,yshift,zshift
 881       logical energy_dec /.true./
 882 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 883       evdw=0.0D0
 884       evdw_t=0.0d0
 885       lprn=.false.
 886 c      if (icall.gt.0) lprn=.true.
 887       ind=0
 888       do i=iatsc_s,iatsc_e
 889         itypi=iabs(itype(i))
 890         if (itypi.eq.ntyp1) cycle
 891         itypi1=iabs(itype(i+1))
 892         xi=c(1,nres+i)
 893         yi=c(2,nres+i)
 894         zi=c(3,nres+i)
 895           xi=mod(xi,boxxsize)
 896           if (xi.lt.0) xi=xi+boxxsize
 897           yi=mod(yi,boxysize)
 898           if (yi.lt.0) yi=yi+boxysize
 899           zi=mod(zi,boxzsize)
 900           if (zi.lt.0) zi=zi+boxzsize
 901         dxi=dc_norm(1,nres+i)
 902         dyi=dc_norm(2,nres+i)
 903         dzi=dc_norm(3,nres+i)
 904         dsci_inv=vbld_inv(i+nres)
 905 C
 906 C Calculate SC interaction energy.
 907 C
 908         do iint=1,nint_gr(i)
 909           do j=istart(i,iint),iend(i,iint)
 910             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 911
 912 c              write(iout,*) "PRZED ZWYKLE", evdwij
 913               call dyn_ssbond_ene(i,j,evdwij)
 914 c              write(iout,*) "PO ZWYKLE", evdwij
 915
 916               evdw=evdw+evdwij
 917               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 918      &                        'evdw',i,j,evdwij,' ss'
 919 C triple bond artifac removal
 920              do k=j+1,iend(i,iint)
 921 C search over all next residues
 922               if (dyn_ss_mask(k)) then
 923 C check if they are cysteins
 924 C              write(iout,*) 'k=',k
 925
 926 c              write(iout,*) "PRZED TRI", evdwij
 927                evdwij_przed_tri=evdwij
 928               call triple_ssbond_ene(i,j,k,evdwij)
 929 c               if(evdwij_przed_tri.ne.evdwij) then
 930 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 931 c               endif
 932
 933 c              write(iout,*) "PO TRI", evdwij
 934 C call the energy function that removes the artifical triple disulfide
 935 C bond the soubroutine is located in ssMD.F
 936               evdw=evdw+evdwij
 937               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 938      &                        'evdw',i,j,evdwij,'tss'
 939               endif!dyn_ss_mask(k)
 940              enddo! k
 941             ELSE
 942             ind=ind+1
 943             itypj=iabs(itype(j))
 944             if (itypj.eq.ntyp1) cycle
 945             dscj_inv=vbld_inv(j+nres)
 946             sig0ij=sigma(itypi,itypj)
 947             chi1=chi(itypi,itypj)
 948             chi2=chi(itypj,itypi)
 949             chi12=chi1*chi2
 950             chip1=chip(itypi)
 951             chip2=chip(itypj)
 952             chip12=chip1*chip2
 953             alf1=alp(itypi)
 954             alf2=alp(itypj)
 955             alf12=0.5D0*(alf1+alf2)
 956 C For diagnostics only!!!
 957 c           chi1=0.0D0
 958 c           chi2=0.0D0
 959 c           chi12=0.0D0
 960 c           chip1=0.0D0
 961 c           chip2=0.0D0
 962 c           chip12=0.0D0
 963 c           alf1=0.0D0
 964 c           alf2=0.0D0
 965 c           alf12=0.0D0
 966             xj=c(1,nres+j)
 967             yj=c(2,nres+j)
 968             zj=c(3,nres+j)
 969           xj=mod(xj,boxxsize)
 970           if (xj.lt.0) xj=xj+boxxsize
 971           yj=mod(yj,boxysize)
 972           if (yj.lt.0) yj=yj+boxysize
 973           zj=mod(zj,boxzsize)
 974           if (zj.lt.0) zj=zj+boxzsize
 975       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 976       xj_safe=xj
 977       yj_safe=yj
 978       zj_safe=zj
 979       subchap=0
 980       do xshift=-1,1
 981       do yshift=-1,1
 982       do zshift=-1,1
 983           xj=xj_safe+xshift*boxxsize
 984           yj=yj_safe+yshift*boxysize
 985           zj=zj_safe+zshift*boxzsize
 986           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 987           if(dist_temp.lt.dist_init) then
 988             dist_init=dist_temp
 989             xj_temp=xj
 990             yj_temp=yj
 991             zj_temp=zj
 992             subchap=1
 993           endif
 994        enddo
 995        enddo
 996        enddo
 997        if (subchap.eq.1) then
 998           xj=xj_temp-xi
 999           yj=yj_temp-yi
1000           zj=zj_temp-zi
1001        else
1002           xj=xj_safe-xi
1003           yj=yj_safe-yi
1004           zj=zj_safe-zi
1005        endif
1006             dxj=dc_norm(1,nres+j)
1007             dyj=dc_norm(2,nres+j)
1008             dzj=dc_norm(3,nres+j)
1009 c            write (iout,*) i,j,xj,yj,zj
1010             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1011             rij=dsqrt(rrij)
1012             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1013             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1014             if (sss.le.0.0d0) cycle
1015 C Calculate angle-dependent terms of energy and contributions to their
1016 C derivatives.
1017             call sc_angular
1018             sigsq=1.0D0/sigsq
1019             sig=sig0ij*dsqrt(sigsq)
1020             rij_shift=1.0D0/rij-sig+sig0ij
1021 C I hate to put IF's in the loops, but here don't have another choice!!!!
1022             if (rij_shift.le.0.0D0) then
1023               evdw=1.0D20
1024               return
1025             endif
1026             sigder=-sig*sigsq
1027 c---------------------------------------------------------------
1028             rij_shift=1.0D0/rij_shift
1029             fac=rij_shift**expon
1030             e1=fac*fac*aa(itypi,itypj)
1031             e2=fac*bb(itypi,itypj)
1032             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1033             eps2der=evdwij*eps3rt
1034             eps3der=evdwij*eps2rt
1035             evdwij=evdwij*eps2rt*eps3rt
1036             if (bb(itypi,itypj).gt.0) then
1037               evdw=evdw+evdwij*sss
1038             else
1039               evdw_t=evdw_t+evdwij*sss
1040             endif
1041             ij=icant(itypi,itypj)
1042             aux=eps1*eps2rt**2*eps3rt**2
1043 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1044 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1045 c     &         aux*e2/eps(itypi,itypj)
1046 c            if (lprn) then
1047             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1048             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1049             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1050      &        restyp(itypi),i,restyp(itypj),j,
1051      &        epsi,sigm,chi1,chi2,chip1,chip2,
1052      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1053      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1054      &        evdwij
1055              write (iout,*) "pratial sum", evdw,evdw_t
1056 c            endif
1057             if (calc_grad) then
1058 C Calculate gradient components.
1059             e1=e1*eps1*eps2rt**2*eps3rt**2
1060             fac=-expon*(e1+evdwij)*rij_shift
1061             sigder=fac*sigder
1062             fac=rij*fac
1063             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1064 C Calculate the radial part of the gradient
1065             gg(1)=xj*fac
1066             gg(2)=yj*fac
1067             gg(3)=zj*fac
1068 C Calculate angular part of the gradient.
1069             call sc_grad
1070             endif
1071             ENDIF    ! dyn_ss
1072           enddo      ! j
1073         enddo        ! iint
1074       enddo          ! i
1075       return
1076       end
1077 C-----------------------------------------------------------------------------
1078       subroutine egbv(evdw,evdw_t)
1079 C
1080 C This subroutine calculates the interaction energy of nonbonded side chains
1081 C assuming the Gay-Berne-Vorobjev potential of interaction.
1082 C
1083       implicit real*8 (a-h,o-z)
1084       include 'DIMENSIONS'
1085       include 'sizesclu.dat'
1086       include "DIMENSIONS.COMPAR"
1087       include 'COMMON.GEO'
1088       include 'COMMON.VAR'
1089       include 'COMMON.LOCAL'
1090       include 'COMMON.CHAIN'
1091       include 'COMMON.DERIV'
1092       include 'COMMON.NAMES'
1093       include 'COMMON.INTERACT'
1094       include 'COMMON.IOUNITS'
1095       include 'COMMON.CALC'
1096       common /srutu/ icall
1097       logical lprn
1098       integer icant
1099       external icant
1100       evdw=0.0D0
1101       evdw_t=0.0d0
1102 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1103       evdw=0.0D0
1104       lprn=.false.
1105 c      if (icall.gt.0) lprn=.true.
1106       ind=0
1107       do i=iatsc_s,iatsc_e
1108         itypi=iabs(itype(i))
1109         if (itypi.eq.ntyp1) cycle
1110         itypi1=iabs(itype(i+1))
1111         xi=c(1,nres+i)
1112         yi=c(2,nres+i)
1113         zi=c(3,nres+i)
1114         dxi=dc_norm(1,nres+i)
1115         dyi=dc_norm(2,nres+i)
1116         dzi=dc_norm(3,nres+i)
1117         dsci_inv=vbld_inv(i+nres)
1118 C
1119 C Calculate SC interaction energy.
1120 C
1121         do iint=1,nint_gr(i)
1122           do j=istart(i,iint),iend(i,iint)
1123             ind=ind+1
1124             itypj=iabs(itype(j))
1125             if (itypj.eq.ntyp1) cycle
1126             dscj_inv=vbld_inv(j+nres)
1127             sig0ij=sigma(itypi,itypj)
1128             r0ij=r0(itypi,itypj)
1129             chi1=chi(itypi,itypj)
1130             chi2=chi(itypj,itypi)
1131             chi12=chi1*chi2
1132             chip1=chip(itypi)
1133             chip2=chip(itypj)
1134             chip12=chip1*chip2
1135             alf1=alp(itypi)
1136             alf2=alp(itypj)
1137             alf12=0.5D0*(alf1+alf2)
1138 C For diagnostics only!!!
1139 c           chi1=0.0D0
1140 c           chi2=0.0D0
1141 c           chi12=0.0D0
1142 c           chip1=0.0D0
1143 c           chip2=0.0D0
1144 c           chip12=0.0D0
1145 c           alf1=0.0D0
1146 c           alf2=0.0D0
1147 c           alf12=0.0D0
1148             xj=c(1,nres+j)-xi
1149             yj=c(2,nres+j)-yi
1150             zj=c(3,nres+j)-zi
1151             dxj=dc_norm(1,nres+j)
1152             dyj=dc_norm(2,nres+j)
1153             dzj=dc_norm(3,nres+j)
1154             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1155             rij=dsqrt(rrij)
1156 C Calculate angle-dependent terms of energy and contributions to their
1157 C derivatives.
1158             call sc_angular
1159             sigsq=1.0D0/sigsq
1160             sig=sig0ij*dsqrt(sigsq)
1161             rij_shift=1.0D0/rij-sig+r0ij
1162 C I hate to put IF's in the loops, but here don't have another choice!!!!
1163             if (rij_shift.le.0.0D0) then
1164               evdw=1.0D20
1165               return
1166             endif
1167             sigder=-sig*sigsq
1168 c---------------------------------------------------------------
1169             rij_shift=1.0D0/rij_shift
1170             fac=rij_shift**expon
1171             e1=fac*fac*aa(itypi,itypj)
1172             e2=fac*bb(itypi,itypj)
1173             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1174             eps2der=evdwij*eps3rt
1175             eps3der=evdwij*eps2rt
1176             fac_augm=rrij**expon
1177             e_augm=augm(itypi,itypj)*fac_augm
1178             evdwij=evdwij*eps2rt*eps3rt
1179             if (bb(itypi,itypj).gt.0.0d0) then
1180               evdw=evdw+evdwij+e_augm
1181             else
1182               evdw_t=evdw_t+evdwij+e_augm
1183             endif
1184             ij=icant(itypi,itypj)
1185             aux=eps1*eps2rt**2*eps3rt**2
1186 c            if (lprn) then
1187 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1188 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1189 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1190 c     &        restyp(itypi),i,restyp(itypj),j,
1191 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1192 c     &        chi1,chi2,chip1,chip2,
1193 c     &        eps1,eps2rt**2,eps3rt**2,
1194 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1195 c     &        evdwij+e_augm
1196 c            endif
1197             if (calc_grad) then
1198 C Calculate gradient components.
1199             e1=e1*eps1*eps2rt**2*eps3rt**2
1200             fac=-expon*(e1+evdwij)*rij_shift
1201             sigder=fac*sigder
1202             fac=rij*fac-2*expon*rrij*e_augm
1203 C Calculate the radial part of the gradient
1204             gg(1)=xj*fac
1205             gg(2)=yj*fac
1206             gg(3)=zj*fac
1207 C Calculate angular part of the gradient.
1208             call sc_grad
1209             endif
1210           enddo      ! j
1211         enddo        ! iint
1212       enddo          ! i
1213       return
1214       end
1215 C-----------------------------------------------------------------------------
1216       subroutine sc_angular
1217 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1218 C om12. Called by ebp, egb, and egbv.
1219       implicit none
1220       include 'COMMON.CALC'
1221       erij(1)=xj*rij
1222       erij(2)=yj*rij
1223       erij(3)=zj*rij
1224       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1225       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1226       om12=dxi*dxj+dyi*dyj+dzi*dzj
1227       chiom12=chi12*om12
1228 C Calculate eps1(om12) and its derivative in om12
1229       faceps1=1.0D0-om12*chiom12
1230       faceps1_inv=1.0D0/faceps1
1231       eps1=dsqrt(faceps1_inv)
1232 C Following variable is eps1*deps1/dom12
1233       eps1_om12=faceps1_inv*chiom12
1234 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1235 C and om12.
1236       om1om2=om1*om2
1237       chiom1=chi1*om1
1238       chiom2=chi2*om2
1239       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1240       sigsq=1.0D0-facsig*faceps1_inv
1241       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1242       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1243       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1244 C Calculate eps2 and its derivatives in om1, om2, and om12.
1245       chipom1=chip1*om1
1246       chipom2=chip2*om2
1247       chipom12=chip12*om12
1248       facp=1.0D0-om12*chipom12
1249       facp_inv=1.0D0/facp
1250       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1251 C Following variable is the square root of eps2
1252       eps2rt=1.0D0-facp1*facp_inv
1253 C Following three variables are the derivatives of the square root of eps
1254 C in om1, om2, and om12.
1255       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1256       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1257       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1258 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1259       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1260 C Calculate whole angle-dependent part of epsilon and contributions
1261 C to its derivatives
1262       return
1263       end
1264 C----------------------------------------------------------------------------
1265       subroutine sc_grad
1266       implicit real*8 (a-h,o-z)
1267       include 'DIMENSIONS'
1268       include 'sizesclu.dat'
1269       include 'COMMON.CHAIN'
1270       include 'COMMON.DERIV'
1271       include 'COMMON.CALC'
1272       double precision dcosom1(3),dcosom2(3)
1273       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1274       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1275       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1276      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1277       do k=1,3
1278         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1279         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1280       enddo
1281       do k=1,3
1282         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1283       enddo
1284       do k=1,3
1285         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1286      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1287      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1288         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1289      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1290      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1291       enddo
1292 C
1293 C Calculate the components of the gradient in DC and X
1294 C
1295       do k=i,j-1
1296         do l=1,3
1297           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1298         enddo
1299       enddo
1300       return
1301       end
1302 c------------------------------------------------------------------------------
1303       subroutine vec_and_deriv
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'sizesclu.dat'
1307       include 'COMMON.IOUNITS'
1308       include 'COMMON.GEO'
1309       include 'COMMON.VAR'
1310       include 'COMMON.LOCAL'
1311       include 'COMMON.CHAIN'
1312       include 'COMMON.VECTORS'
1313       include 'COMMON.DERIV'
1314       include 'COMMON.INTERACT'
1315       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1316 C Compute the local reference systems. For reference system (i), the
1317 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1318 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1319       do i=1,nres-1
1320 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1321           if (i.eq.nres-1) then
1322 C Case of the last full residue
1323 C Compute the Z-axis
1324             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1325             costh=dcos(pi-theta(nres))
1326             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1327             do k=1,3
1328               uz(k,i)=fac*uz(k,i)
1329             enddo
1330             if (calc_grad) then
1331 C Compute the derivatives of uz
1332             uzder(1,1,1)= 0.0d0
1333             uzder(2,1,1)=-dc_norm(3,i-1)
1334             uzder(3,1,1)= dc_norm(2,i-1)
1335             uzder(1,2,1)= dc_norm(3,i-1)
1336             uzder(2,2,1)= 0.0d0
1337             uzder(3,2,1)=-dc_norm(1,i-1)
1338             uzder(1,3,1)=-dc_norm(2,i-1)
1339             uzder(2,3,1)= dc_norm(1,i-1)
1340             uzder(3,3,1)= 0.0d0
1341             uzder(1,1,2)= 0.0d0
1342             uzder(2,1,2)= dc_norm(3,i)
1343             uzder(3,1,2)=-dc_norm(2,i)
1344             uzder(1,2,2)=-dc_norm(3,i)
1345             uzder(2,2,2)= 0.0d0
1346             uzder(3,2,2)= dc_norm(1,i)
1347             uzder(1,3,2)= dc_norm(2,i)
1348             uzder(2,3,2)=-dc_norm(1,i)
1349             uzder(3,3,2)= 0.0d0
1350             endif
1351 C Compute the Y-axis
1352             facy=fac
1353             do k=1,3
1354               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1355             enddo
1356             if (calc_grad) then
1357 C Compute the derivatives of uy
1358             do j=1,3
1359               do k=1,3
1360                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1361      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1362                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1363               enddo
1364               uyder(j,j,1)=uyder(j,j,1)-costh
1365               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1366             enddo
1367             do j=1,2
1368               do k=1,3
1369                 do l=1,3
1370                   uygrad(l,k,j,i)=uyder(l,k,j)
1371                   uzgrad(l,k,j,i)=uzder(l,k,j)
1372                 enddo
1373               enddo
1374             enddo
1375             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1376             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1377             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1378             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1379             endif
1380           else
1381 C Other residues
1382 C Compute the Z-axis
1383             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1384             costh=dcos(pi-theta(i+2))
1385             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1386             do k=1,3
1387               uz(k,i)=fac*uz(k,i)
1388             enddo
1389             if (calc_grad) then
1390 C Compute the derivatives of uz
1391             uzder(1,1,1)= 0.0d0
1392             uzder(2,1,1)=-dc_norm(3,i+1)
1393             uzder(3,1,1)= dc_norm(2,i+1)
1394             uzder(1,2,1)= dc_norm(3,i+1)
1395             uzder(2,2,1)= 0.0d0
1396             uzder(3,2,1)=-dc_norm(1,i+1)
1397             uzder(1,3,1)=-dc_norm(2,i+1)
1398             uzder(2,3,1)= dc_norm(1,i+1)
1399             uzder(3,3,1)= 0.0d0
1400             uzder(1,1,2)= 0.0d0
1401             uzder(2,1,2)= dc_norm(3,i)
1402             uzder(3,1,2)=-dc_norm(2,i)
1403             uzder(1,2,2)=-dc_norm(3,i)
1404             uzder(2,2,2)= 0.0d0
1405             uzder(3,2,2)= dc_norm(1,i)
1406             uzder(1,3,2)= dc_norm(2,i)
1407             uzder(2,3,2)=-dc_norm(1,i)
1408             uzder(3,3,2)= 0.0d0
1409             endif
1410 C Compute the Y-axis
1411             facy=fac
1412             do k=1,3
1413               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1414             enddo
1415             if (calc_grad) then
1416 C Compute the derivatives of uy
1417             do j=1,3
1418               do k=1,3
1419                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1420      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1421                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1422               enddo
1423               uyder(j,j,1)=uyder(j,j,1)-costh
1424               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1425             enddo
1426             do j=1,2
1427               do k=1,3
1428                 do l=1,3
1429                   uygrad(l,k,j,i)=uyder(l,k,j)
1430                   uzgrad(l,k,j,i)=uzder(l,k,j)
1431                 enddo
1432               enddo
1433             enddo
1434             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1435             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1436             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1437             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1438           endif
1439           endif
1440       enddo
1441       if (calc_grad) then
1442       do i=1,nres-1
1443         vbld_inv_temp(1)=vbld_inv(i+1)
1444         if (i.lt.nres-1) then
1445           vbld_inv_temp(2)=vbld_inv(i+2)
1446         else
1447           vbld_inv_temp(2)=vbld_inv(i)
1448         endif
1449         do j=1,2
1450           do k=1,3
1451             do l=1,3
1452               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1453               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1454             enddo
1455           enddo
1456         enddo
1457       enddo
1458       endif
1459       return
1460       end
1461 C-----------------------------------------------------------------------------
1462       subroutine vec_and_deriv_test
1463       implicit real*8 (a-h,o-z)
1464       include 'DIMENSIONS'
1465       include 'sizesclu.dat'
1466       include 'COMMON.IOUNITS'
1467       include 'COMMON.GEO'
1468       include 'COMMON.VAR'
1469       include 'COMMON.LOCAL'
1470       include 'COMMON.CHAIN'
1471       include 'COMMON.VECTORS'
1472       dimension uyder(3,3,2),uzder(3,3,2)
1473 C Compute the local reference systems. For reference system (i), the
1474 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1475 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1476       do i=1,nres-1
1477           if (i.eq.nres-1) then
1478 C Case of the last full residue
1479 C Compute the Z-axis
1480             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1481             costh=dcos(pi-theta(nres))
1482             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1483 c            write (iout,*) 'fac',fac,
1484 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1485             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1486             do k=1,3
1487               uz(k,i)=fac*uz(k,i)
1488             enddo
1489 C Compute the derivatives of uz
1490             uzder(1,1,1)= 0.0d0
1491             uzder(2,1,1)=-dc_norm(3,i-1)
1492             uzder(3,1,1)= dc_norm(2,i-1)
1493             uzder(1,2,1)= dc_norm(3,i-1)
1494             uzder(2,2,1)= 0.0d0
1495             uzder(3,2,1)=-dc_norm(1,i-1)
1496             uzder(1,3,1)=-dc_norm(2,i-1)
1497             uzder(2,3,1)= dc_norm(1,i-1)
1498             uzder(3,3,1)= 0.0d0
1499             uzder(1,1,2)= 0.0d0
1500             uzder(2,1,2)= dc_norm(3,i)
1501             uzder(3,1,2)=-dc_norm(2,i)
1502             uzder(1,2,2)=-dc_norm(3,i)
1503             uzder(2,2,2)= 0.0d0
1504             uzder(3,2,2)= dc_norm(1,i)
1505             uzder(1,3,2)= dc_norm(2,i)
1506             uzder(2,3,2)=-dc_norm(1,i)
1507             uzder(3,3,2)= 0.0d0
1508 C Compute the Y-axis
1509             do k=1,3
1510               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1511             enddo
1512             facy=fac
1513             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1514      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1515      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1516             do k=1,3
1517 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1518               uy(k,i)=
1519 c     &        facy*(
1520      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1521      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1522 c     &        )
1523             enddo
1524 c            write (iout,*) 'facy',facy,
1525 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1526             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1527             do k=1,3
1528               uy(k,i)=facy*uy(k,i)
1529             enddo
1530 C Compute the derivatives of uy
1531             do j=1,3
1532               do k=1,3
1533                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1534      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1535                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1536               enddo
1537 c              uyder(j,j,1)=uyder(j,j,1)-costh
1538 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1539               uyder(j,j,1)=uyder(j,j,1)
1540      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1541               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1542      &          +uyder(j,j,2)
1543             enddo
1544             do j=1,2
1545               do k=1,3
1546                 do l=1,3
1547                   uygrad(l,k,j,i)=uyder(l,k,j)
1548                   uzgrad(l,k,j,i)=uzder(l,k,j)
1549                 enddo
1550               enddo
1551             enddo
1552             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1553             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1554             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1555             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1556           else
1557 C Other residues
1558 C Compute the Z-axis
1559             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1560             costh=dcos(pi-theta(i+2))
1561             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1562             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1563             do k=1,3
1564               uz(k,i)=fac*uz(k,i)
1565             enddo
1566 C Compute the derivatives of uz
1567             uzder(1,1,1)= 0.0d0
1568             uzder(2,1,1)=-dc_norm(3,i+1)
1569             uzder(3,1,1)= dc_norm(2,i+1)
1570             uzder(1,2,1)= dc_norm(3,i+1)
1571             uzder(2,2,1)= 0.0d0
1572             uzder(3,2,1)=-dc_norm(1,i+1)
1573             uzder(1,3,1)=-dc_norm(2,i+1)
1574             uzder(2,3,1)= dc_norm(1,i+1)
1575             uzder(3,3,1)= 0.0d0
1576             uzder(1,1,2)= 0.0d0
1577             uzder(2,1,2)= dc_norm(3,i)
1578             uzder(3,1,2)=-dc_norm(2,i)
1579             uzder(1,2,2)=-dc_norm(3,i)
1580             uzder(2,2,2)= 0.0d0
1581             uzder(3,2,2)= dc_norm(1,i)
1582             uzder(1,3,2)= dc_norm(2,i)
1583             uzder(2,3,2)=-dc_norm(1,i)
1584             uzder(3,3,2)= 0.0d0
1585 C Compute the Y-axis
1586             facy=fac
1587             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1588      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1589      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1590             do k=1,3
1591 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1592               uy(k,i)=
1593 c     &        facy*(
1594      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1595      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1596 c     &        )
1597             enddo
1598 c            write (iout,*) 'facy',facy,
1599 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1600             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1601             do k=1,3
1602               uy(k,i)=facy*uy(k,i)
1603             enddo
1604 C Compute the derivatives of uy
1605             do j=1,3
1606               do k=1,3
1607                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1608      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1609                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1610               enddo
1611 c              uyder(j,j,1)=uyder(j,j,1)-costh
1612 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1613               uyder(j,j,1)=uyder(j,j,1)
1614      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1615               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1616      &          +uyder(j,j,2)
1617             enddo
1618             do j=1,2
1619               do k=1,3
1620                 do l=1,3
1621                   uygrad(l,k,j,i)=uyder(l,k,j)
1622                   uzgrad(l,k,j,i)=uzder(l,k,j)
1623                 enddo
1624               enddo
1625             enddo
1626             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1627             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1628             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1629             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1630           endif
1631       enddo
1632       do i=1,nres-1
1633         do j=1,2
1634           do k=1,3
1635             do l=1,3
1636               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1637               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1638             enddo
1639           enddo
1640         enddo
1641       enddo
1642       return
1643       end
1644 C-----------------------------------------------------------------------------
1645       subroutine check_vecgrad
1646       implicit real*8 (a-h,o-z)
1647       include 'DIMENSIONS'
1648       include 'sizesclu.dat'
1649       include 'COMMON.IOUNITS'
1650       include 'COMMON.GEO'
1651       include 'COMMON.VAR'
1652       include 'COMMON.LOCAL'
1653       include 'COMMON.CHAIN'
1654       include 'COMMON.VECTORS'
1655       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1656       dimension uyt(3,maxres),uzt(3,maxres)
1657       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1658       double precision delta /1.0d-7/
1659       call vec_and_deriv
1660 cd      do i=1,nres
1661 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1662 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1663 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1664 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1665 cd     &     (dc_norm(if90,i),if90=1,3)
1666 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1667 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1668 cd          write(iout,'(a)')
1669 cd      enddo
1670       do i=1,nres
1671         do j=1,2
1672           do k=1,3
1673             do l=1,3
1674               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1675               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1676             enddo
1677           enddo
1678         enddo
1679       enddo
1680       call vec_and_deriv
1681       do i=1,nres
1682         do j=1,3
1683           uyt(j,i)=uy(j,i)
1684           uzt(j,i)=uz(j,i)
1685         enddo
1686       enddo
1687       do i=1,nres
1688 cd        write (iout,*) 'i=',i
1689         do k=1,3
1690           erij(k)=dc_norm(k,i)
1691         enddo
1692         do j=1,3
1693           do k=1,3
1694             dc_norm(k,i)=erij(k)
1695           enddo
1696           dc_norm(j,i)=dc_norm(j,i)+delta
1697 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1698 c          do k=1,3
1699 c            dc_norm(k,i)=dc_norm(k,i)/fac
1700 c          enddo
1701 c          write (iout,*) (dc_norm(k,i),k=1,3)
1702 c          write (iout,*) (erij(k),k=1,3)
1703           call vec_and_deriv
1704           do k=1,3
1705             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1706             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1707             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1708             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1709           enddo
1710 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1711 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1712 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1713         enddo
1714         do k=1,3
1715           dc_norm(k,i)=erij(k)
1716         enddo
1717 cd        do k=1,3
1718 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1719 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1720 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1721 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1722 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1723 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1724 cd          write (iout,'(a)')
1725 cd        enddo
1726       enddo
1727       return
1728       end
1729 C--------------------------------------------------------------------------
1730       subroutine set_matrices
1731       implicit real*8 (a-h,o-z)
1732       include 'DIMENSIONS'
1733       include 'sizesclu.dat'
1734       include 'COMMON.IOUNITS'
1735       include 'COMMON.GEO'
1736       include 'COMMON.VAR'
1737       include 'COMMON.LOCAL'
1738       include 'COMMON.CHAIN'
1739       include 'COMMON.DERIV'
1740       include 'COMMON.INTERACT'
1741       include 'COMMON.CONTACTS'
1742       include 'COMMON.TORSION'
1743       include 'COMMON.VECTORS'
1744       include 'COMMON.FFIELD'
1745       double precision auxvec(2),auxmat(2,2)
1746 C
1747 C Compute the virtual-bond-torsional-angle dependent quantities needed
1748 C to calculate the el-loc multibody terms of various order.
1749 C
1750       do i=3,nres+1
1751         if (i .lt. nres+1) then
1752           sin1=dsin(phi(i))
1753           cos1=dcos(phi(i))
1754           sintab(i-2)=sin1
1755           costab(i-2)=cos1
1756           obrot(1,i-2)=cos1
1757           obrot(2,i-2)=sin1
1758           sin2=dsin(2*phi(i))
1759           cos2=dcos(2*phi(i))
1760           sintab2(i-2)=sin2
1761           costab2(i-2)=cos2
1762           obrot2(1,i-2)=cos2
1763           obrot2(2,i-2)=sin2
1764           Ug(1,1,i-2)=-cos1
1765           Ug(1,2,i-2)=-sin1
1766           Ug(2,1,i-2)=-sin1
1767           Ug(2,2,i-2)= cos1
1768           Ug2(1,1,i-2)=-cos2
1769           Ug2(1,2,i-2)=-sin2
1770           Ug2(2,1,i-2)=-sin2
1771           Ug2(2,2,i-2)= cos2
1772         else
1773           costab(i-2)=1.0d0
1774           sintab(i-2)=0.0d0
1775           obrot(1,i-2)=1.0d0
1776           obrot(2,i-2)=0.0d0
1777           obrot2(1,i-2)=0.0d0
1778           obrot2(2,i-2)=0.0d0
1779           Ug(1,1,i-2)=1.0d0
1780           Ug(1,2,i-2)=0.0d0
1781           Ug(2,1,i-2)=0.0d0
1782           Ug(2,2,i-2)=1.0d0
1783           Ug2(1,1,i-2)=0.0d0
1784           Ug2(1,2,i-2)=0.0d0
1785           Ug2(2,1,i-2)=0.0d0
1786           Ug2(2,2,i-2)=0.0d0
1787         endif
1788         if (i .gt. 3 .and. i .lt. nres+1) then
1789           obrot_der(1,i-2)=-sin1
1790           obrot_der(2,i-2)= cos1
1791           Ugder(1,1,i-2)= sin1
1792           Ugder(1,2,i-2)=-cos1
1793           Ugder(2,1,i-2)=-cos1
1794           Ugder(2,2,i-2)=-sin1
1795           dwacos2=cos2+cos2
1796           dwasin2=sin2+sin2
1797           obrot2_der(1,i-2)=-dwasin2
1798           obrot2_der(2,i-2)= dwacos2
1799           Ug2der(1,1,i-2)= dwasin2
1800           Ug2der(1,2,i-2)=-dwacos2
1801           Ug2der(2,1,i-2)=-dwacos2
1802           Ug2der(2,2,i-2)=-dwasin2
1803         else
1804           obrot_der(1,i-2)=0.0d0
1805           obrot_der(2,i-2)=0.0d0
1806           Ugder(1,1,i-2)=0.0d0
1807           Ugder(1,2,i-2)=0.0d0
1808           Ugder(2,1,i-2)=0.0d0
1809           Ugder(2,2,i-2)=0.0d0
1810           obrot2_der(1,i-2)=0.0d0
1811           obrot2_der(2,i-2)=0.0d0
1812           Ug2der(1,1,i-2)=0.0d0
1813           Ug2der(1,2,i-2)=0.0d0
1814           Ug2der(2,1,i-2)=0.0d0
1815           Ug2der(2,2,i-2)=0.0d0
1816         endif
1817         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1818           if (itype(i-2).le.ntyp) then
1819             iti = itortyp(itype(i-2))
1820           else
1821             iti=ntortyp+1
1822           endif
1823         else
1824           iti=ntortyp+1
1825         endif
1826         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1827           if (itype(i-1).le.ntyp) then
1828             iti1 = itortyp(itype(i-1))
1829           else
1830             iti1=ntortyp+1
1831           endif
1832         else
1833           iti1=ntortyp+1
1834         endif
1835 cd        write (iout,*) '*******i',i,' iti1',iti
1836 cd        write (iout,*) 'b1',b1(:,iti)
1837 cd        write (iout,*) 'b2',b2(:,iti)
1838 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1839 c        print *,"itilde1 i iti iti1",i,iti,iti1
1840         if (i .gt. iatel_s+2) then
1841           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1842           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1843           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1844           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1845           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1846           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1847           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1848         else
1849           do k=1,2
1850             Ub2(k,i-2)=0.0d0
1851             Ctobr(k,i-2)=0.0d0
1852             Dtobr2(k,i-2)=0.0d0
1853             do l=1,2
1854               EUg(l,k,i-2)=0.0d0
1855               CUg(l,k,i-2)=0.0d0
1856               DUg(l,k,i-2)=0.0d0
1857               DtUg2(l,k,i-2)=0.0d0
1858             enddo
1859           enddo
1860         endif
1861 c        print *,"itilde2 i iti iti1",i,iti,iti1
1862         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1863         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1864         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1865         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1866         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1867         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1868         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1869 c        print *,"itilde3 i iti iti1",i,iti,iti1
1870         do k=1,2
1871           muder(k,i-2)=Ub2der(k,i-2)
1872         enddo
1873         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1874           if (itype(i-1).le.ntyp) then
1875             iti1 = itortyp(itype(i-1))
1876           else
1877             iti1=ntortyp+1
1878           endif
1879         else
1880           iti1=ntortyp+1
1881         endif
1882         do k=1,2
1883           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1884         enddo
1885 C Vectors and matrices dependent on a single virtual-bond dihedral.
1886         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1887         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1888         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1889         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1890         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1891         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1892         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1893         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1894         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1895 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1896 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1897       enddo
1898 C Matrices dependent on two consecutive virtual-bond dihedrals.
1899 C The order of matrices is from left to right.
1900       do i=2,nres-1
1901         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1902         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1903         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1904         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1905         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1906         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1907         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1908         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1909       enddo
1910 cd      do i=1,nres
1911 cd        iti = itortyp(itype(i))
1912 cd        write (iout,*) i
1913 cd        do j=1,2
1914 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1915 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1916 cd        enddo
1917 cd      enddo
1918       return
1919       end
1920 C--------------------------------------------------------------------------
1921       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1922 C
1923 C This subroutine calculates the average interaction energy and its gradient
1924 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1925 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1926 C The potential depends both on the distance of peptide-group centers and on
1927 C the orientation of the CA-CA virtual bonds.
1928 C
1929       implicit real*8 (a-h,o-z)
1930       include 'DIMENSIONS'
1931       include 'sizesclu.dat'
1932       include 'COMMON.CONTROL'
1933       include 'COMMON.IOUNITS'
1934       include 'COMMON.GEO'
1935       include 'COMMON.VAR'
1936       include 'COMMON.LOCAL'
1937       include 'COMMON.CHAIN'
1938       include 'COMMON.DERIV'
1939       include 'COMMON.INTERACT'
1940       include 'COMMON.CONTACTS'
1941       include 'COMMON.TORSION'
1942       include 'COMMON.VECTORS'
1943       include 'COMMON.FFIELD'
1944       include 'COMMON.SHIELD'
1945
1946       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1947      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1948       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1949      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1950       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1951 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1952       double precision scal_el /0.5d0/
1953 C 12/13/98
1954 C 13-go grudnia roku pamietnego...
1955       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1956      &                   0.0d0,1.0d0,0.0d0,
1957      &                   0.0d0,0.0d0,1.0d0/
1958 cd      write(iout,*) 'In EELEC'
1959 cd      do i=1,nloctyp
1960 cd        write(iout,*) 'Type',i
1961 cd        write(iout,*) 'B1',B1(:,i)
1962 cd        write(iout,*) 'B2',B2(:,i)
1963 cd        write(iout,*) 'CC',CC(:,:,i)
1964 cd        write(iout,*) 'DD',DD(:,:,i)
1965 cd        write(iout,*) 'EE',EE(:,:,i)
1966 cd      enddo
1967 cd      call check_vecgrad
1968 cd      stop
1969       if (icheckgrad.eq.1) then
1970         do i=1,nres-1
1971           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1972           do k=1,3
1973             dc_norm(k,i)=dc(k,i)*fac
1974           enddo
1975 c          write (iout,*) 'i',i,' fac',fac
1976         enddo
1977       endif
1978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1979      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1980      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1981 cd      if (wel_loc.gt.0.0d0) then
1982         if (icheckgrad.eq.1) then
1983         call vec_and_deriv_test
1984         else
1985         call vec_and_deriv
1986         endif
1987         call set_matrices
1988       endif
1989 cd      do i=1,nres-1
1990 cd        write (iout,*) 'i=',i
1991 cd        do k=1,3
1992 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1993 cd        enddo
1994 cd        do k=1,3
1995 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1996 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1997 cd        enddo
1998 cd      enddo
1999       num_conti_hb=0
2000       ees=0.0D0
2001       evdw1=0.0D0
2002       eel_loc=0.0d0
2003       eello_turn3=0.0d0
2004       eello_turn4=0.0d0
2005       ind=0
2006       do i=1,nres
2007         num_cont_hb(i)=0
2008       enddo
2009 cd      print '(a)','Enter EELEC'
2010 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2011       do i=1,nres
2012         gel_loc_loc(i)=0.0d0
2013         gcorr_loc(i)=0.0d0
2014       enddo
2015       do i=iatel_s,iatel_e
2016 C          if (i.eq.1) then
2017            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2018 C     &  .or. itype(i+2).eq.ntyp1) cycle
2019 C          else
2020 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2021 C     &  .or. itype(i+2).eq.ntyp1
2022 C     &  .or. itype(i-1).eq.ntyp1
2023      &) cycle
2024 C         endif
2025         if (itel(i).eq.0) goto 1215
2026         dxi=dc(1,i)
2027         dyi=dc(2,i)
2028         dzi=dc(3,i)
2029         dx_normi=dc_norm(1,i)
2030         dy_normi=dc_norm(2,i)
2031         dz_normi=dc_norm(3,i)
2032         xmedi=c(1,i)+0.5d0*dxi
2033         ymedi=c(2,i)+0.5d0*dyi
2034         zmedi=c(3,i)+0.5d0*dzi
2035           xmedi=mod(xmedi,boxxsize)
2036           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2037           ymedi=mod(ymedi,boxysize)
2038           if (ymedi.lt.0) ymedi=ymedi+boxysize
2039           zmedi=mod(zmedi,boxzsize)
2040           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2041         num_conti=0
2042 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2043         do j=ielstart(i),ielend(i)
2044           if (j.le.1) cycle
2045 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2046 C     & .or.itype(j+2).eq.ntyp1
2047 C     &) cycle
2048 C          else
2049           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2050 C     & .or.itype(j+2).eq.ntyp1
2051 C     & .or.itype(j-1).eq.ntyp1
2052      &) cycle
2053 C         endif
2054           if (itel(j).eq.0) goto 1216
2055           ind=ind+1
2056           iteli=itel(i)
2057           itelj=itel(j)
2058           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2059           aaa=app(iteli,itelj)
2060           bbb=bpp(iteli,itelj)
2061 C Diagnostics only!!!
2062 c         aaa=0.0D0
2063 c         bbb=0.0D0
2064 c         ael6i=0.0D0
2065 c         ael3i=0.0D0
2066 C End diagnostics
2067           ael6i=ael6(iteli,itelj)
2068           ael3i=ael3(iteli,itelj)
2069           dxj=dc(1,j)
2070           dyj=dc(2,j)
2071           dzj=dc(3,j)
2072           dx_normj=dc_norm(1,j)
2073           dy_normj=dc_norm(2,j)
2074           dz_normj=dc_norm(3,j)
2075           xj=c(1,j)+0.5D0*dxj
2076           yj=c(2,j)+0.5D0*dyj
2077           zj=c(3,j)+0.5D0*dzj
2078          xj=mod(xj,boxxsize)
2079           if (xj.lt.0) xj=xj+boxxsize
2080           yj=mod(yj,boxysize)
2081           if (yj.lt.0) yj=yj+boxysize
2082           zj=mod(zj,boxzsize)
2083           if (zj.lt.0) zj=zj+boxzsize
2084       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2085       xj_safe=xj
2086       yj_safe=yj
2087       zj_safe=zj
2088       isubchap=0
2089       do xshift=-1,1
2090       do yshift=-1,1
2091       do zshift=-1,1
2092           xj=xj_safe+xshift*boxxsize
2093           yj=yj_safe+yshift*boxysize
2094           zj=zj_safe+zshift*boxzsize
2095           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2096           if(dist_temp.lt.dist_init) then
2097             dist_init=dist_temp
2098             xj_temp=xj
2099             yj_temp=yj
2100             zj_temp=zj
2101             isubchap=1
2102           endif
2103        enddo
2104        enddo
2105        enddo
2106        if (isubchap.eq.1) then
2107           xj=xj_temp-xmedi
2108           yj=yj_temp-ymedi
2109           zj=zj_temp-zmedi
2110        else
2111           xj=xj_safe-xmedi
2112           yj=yj_safe-ymedi
2113           zj=zj_safe-zmedi
2114        endif
2115
2116           rij=xj*xj+yj*yj+zj*zj
2117             sss=sscale(sqrt(rij))
2118             sssgrad=sscagrad(sqrt(rij))
2119           rrmij=1.0D0/rij
2120           rij=dsqrt(rij)
2121           rmij=1.0D0/rij
2122           r3ij=rrmij*rmij
2123           r6ij=r3ij*r3ij
2124           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2125           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2126           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2127           fac=cosa-3.0D0*cosb*cosg
2128           ev1=aaa*r6ij*r6ij
2129 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2130           if (j.eq.i+2) ev1=scal_el*ev1
2131           ev2=bbb*r6ij
2132           fac3=ael6i*r6ij
2133           fac4=ael3i*r3ij
2134           evdwij=ev1+ev2
2135           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2136           el2=fac4*fac
2137           eesij=el1+el2
2138 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2139 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2140           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2141           if (shield_mode.gt.0) then
2142 C          fac_shield(i)=0.4
2143 C          fac_shield(j)=0.6
2144           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2145           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2146           eesij=(el1+el2)
2147           ees=ees+eesij
2148           else
2149           fac_shield(i)=1.0
2150           fac_shield(j)=1.0
2151           eesij=(el1+el2)
2152           ees=ees+eesij
2153           endif
2154 C          ees=ees+eesij
2155           evdw1=evdw1+evdwij*sss
2156 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2157 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2158 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2159 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2160 C
2161 C Calculate contributions to the Cartesian gradient.
2162 C
2163 #ifdef SPLITELE
2164           facvdw=-6*rrmij*(ev1+evdwij)*sss
2165           facel=-3*rrmij*(el1+eesij)
2166           fac1=fac
2167           erij(1)=xj*rmij
2168           erij(2)=yj*rmij
2169           erij(3)=zj*rmij
2170           if (calc_grad) then
2171 *
2172 * Radial derivatives. First process both termini of the fragment (i,j)
2173 *
2174           ggg(1)=facel*xj
2175           ggg(2)=facel*yj
2176           ggg(3)=facel*zj
2177
2178           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2179      &  (shield_mode.gt.0)) then
2180 C          print *,i,j
2181           do ilist=1,ishield_list(i)
2182            iresshield=shield_list(ilist,i)
2183            do k=1,3
2184            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2185      &      *2.0
2186            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2187      &              rlocshield
2188      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2189             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2190 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2191 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2192 C             if (iresshield.gt.i) then
2193 C               do ishi=i+1,iresshield-1
2194 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2195 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2196 C
2197 C              enddo
2198 C             else
2199 C               do ishi=iresshield,i
2200 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2201 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2202 C
2203 C               enddo
2204 C              endif
2205 C           enddo
2206 C          enddo
2207            enddo
2208           enddo
2209           do ilist=1,ishield_list(j)
2210            iresshield=shield_list(ilist,j)
2211            do k=1,3
2212            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2213      &     *2.0
2214            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2215      &              rlocshield
2216      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2217            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2218            enddo
2219           enddo
2220
2221           do k=1,3
2222             gshieldc(k,i)=gshieldc(k,i)+
2223      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2224             gshieldc(k,j)=gshieldc(k,j)+
2225      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2226             gshieldc(k,i-1)=gshieldc(k,i-1)+
2227      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2228             gshieldc(k,j-1)=gshieldc(k,j-1)+
2229      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2230
2231            enddo
2232            endif
2233
2234           do k=1,3
2235             ghalf=0.5D0*ggg(k)
2236             gelc(k,i)=gelc(k,i)+ghalf
2237             gelc(k,j)=gelc(k,j)+ghalf
2238           enddo
2239 *
2240 * Loop over residues i+1 thru j-1.
2241 *
2242           do k=i+1,j-1
2243             do l=1,3
2244               gelc(l,k)=gelc(l,k)+ggg(l)
2245             enddo
2246           enddo
2247 C          ggg(1)=facvdw*xj
2248 C          ggg(2)=facvdw*yj
2249 C          ggg(3)=facvdw*zj
2250           if (sss.gt.0.0) then
2251           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2252           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2253           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2254           else
2255           ggg(1)=0.0
2256           ggg(2)=0.0
2257           ggg(3)=0.0
2258           endif
2259           do k=1,3
2260             ghalf=0.5D0*ggg(k)
2261             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2262             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2263           enddo
2264 *
2265 * Loop over residues i+1 thru j-1.
2266 *
2267           do k=i+1,j-1
2268             do l=1,3
2269               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2270             enddo
2271           enddo
2272 #else
2273           facvdw=(ev1+evdwij)*sss
2274           facel=el1+eesij
2275           fac1=fac
2276           fac=-3*rrmij*(facvdw+facvdw+facel)
2277           erij(1)=xj*rmij
2278           erij(2)=yj*rmij
2279           erij(3)=zj*rmij
2280           if (calc_grad) then
2281 *
2282 * Radial derivatives. First process both termini of the fragment (i,j)
2283 *
2284           ggg(1)=fac*xj
2285           ggg(2)=fac*yj
2286           ggg(3)=fac*zj
2287           do k=1,3
2288             ghalf=0.5D0*ggg(k)
2289             gelc(k,i)=gelc(k,i)+ghalf
2290             gelc(k,j)=gelc(k,j)+ghalf
2291           enddo
2292 *
2293 * Loop over residues i+1 thru j-1.
2294 *
2295           do k=i+1,j-1
2296             do l=1,3
2297               gelc(l,k)=gelc(l,k)+ggg(l)
2298             enddo
2299           enddo
2300 #endif
2301 *
2302 * Angular part
2303 *
2304           ecosa=2.0D0*fac3*fac1+fac4
2305           fac4=-3.0D0*fac4
2306           fac3=-6.0D0*fac3
2307           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2308           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2309           do k=1,3
2310             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2311             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2312           enddo
2313 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2314 cd   &          (dcosg(k),k=1,3)
2315           do k=1,3
2316             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2317      &      *fac_shield(i)**2*fac_shield(j)**2
2318           enddo
2319           do k=1,3
2320             ghalf=0.5D0*ggg(k)
2321             gelc(k,i)=gelc(k,i)+ghalf
2322      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2323      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2324      &           *fac_shield(i)**2*fac_shield(j)**2
2325
2326             gelc(k,j)=gelc(k,j)+ghalf
2327      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2328      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2329      &           *fac_shield(i)**2*fac_shield(j)**2
2330           enddo
2331           do k=i+1,j-1
2332             do l=1,3
2333               gelc(l,k)=gelc(l,k)+ggg(l)
2334             enddo
2335           enddo
2336           endif
2337
2338           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2339      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2340      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2341 C
2342 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2343 C   energy of a peptide unit is assumed in the form of a second-order
2344 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2345 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2346 C   are computed for EVERY pair of non-contiguous peptide groups.
2347 C
2348           if (j.lt.nres-1) then
2349             j1=j+1
2350             j2=j-1
2351           else
2352             j1=j-1
2353             j2=j-2
2354           endif
2355           kkk=0
2356           do k=1,2
2357             do l=1,2
2358               kkk=kkk+1
2359               muij(kkk)=mu(k,i)*mu(l,j)
2360             enddo
2361           enddo
2362 cd         write (iout,*) 'EELEC: i',i,' j',j
2363 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2364 cd          write(iout,*) 'muij',muij
2365           ury=scalar(uy(1,i),erij)
2366           urz=scalar(uz(1,i),erij)
2367           vry=scalar(uy(1,j),erij)
2368           vrz=scalar(uz(1,j),erij)
2369           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2370           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2371           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2372           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2373 C For diagnostics only
2374 cd          a22=1.0d0
2375 cd          a23=1.0d0
2376 cd          a32=1.0d0
2377 cd          a33=1.0d0
2378           fac=dsqrt(-ael6i)*r3ij
2379 cd          write (2,*) 'fac=',fac
2380 C For diagnostics only
2381 cd          fac=1.0d0
2382           a22=a22*fac
2383           a23=a23*fac
2384           a32=a32*fac
2385           a33=a33*fac
2386 cd          write (iout,'(4i5,4f10.5)')
2387 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2388 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2389 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2390 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2391 cd          write (iout,'(4f10.5)')
2392 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2393 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2394 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2395 cd           write (iout,'(2i3,9f10.5/)') i,j,
2396 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2397           if (calc_grad) then
2398 C Derivatives of the elements of A in virtual-bond vectors
2399           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2400 cd          do k=1,3
2401 cd            do l=1,3
2402 cd              erder(k,l)=0.0d0
2403 cd            enddo
2404 cd          enddo
2405           do k=1,3
2406             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2407             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2408             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2409             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2410             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2411             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2412             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2413             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2414             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2415             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2416             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2417             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2418           enddo
2419 cd          do k=1,3
2420 cd            do l=1,3
2421 cd              uryg(k,l)=0.0d0
2422 cd              urzg(k,l)=0.0d0
2423 cd              vryg(k,l)=0.0d0
2424 cd              vrzg(k,l)=0.0d0
2425 cd            enddo
2426 cd          enddo
2427 C Compute radial contributions to the gradient
2428           facr=-3.0d0*rrmij
2429           a22der=a22*facr
2430           a23der=a23*facr
2431           a32der=a32*facr
2432           a33der=a33*facr
2433 cd          a22der=0.0d0
2434 cd          a23der=0.0d0
2435 cd          a32der=0.0d0
2436 cd          a33der=0.0d0
2437           agg(1,1)=a22der*xj
2438           agg(2,1)=a22der*yj
2439           agg(3,1)=a22der*zj
2440           agg(1,2)=a23der*xj
2441           agg(2,2)=a23der*yj
2442           agg(3,2)=a23der*zj
2443           agg(1,3)=a32der*xj
2444           agg(2,3)=a32der*yj
2445           agg(3,3)=a32der*zj
2446           agg(1,4)=a33der*xj
2447           agg(2,4)=a33der*yj
2448           agg(3,4)=a33der*zj
2449 C Add the contributions coming from er
2450           fac3=-3.0d0*fac
2451           do k=1,3
2452             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2453             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2454             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2455             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2456           enddo
2457           do k=1,3
2458 C Derivatives in DC(i)
2459             ghalf1=0.5d0*agg(k,1)
2460             ghalf2=0.5d0*agg(k,2)
2461             ghalf3=0.5d0*agg(k,3)
2462             ghalf4=0.5d0*agg(k,4)
2463             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2464      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2465             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2466      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2467             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2468      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2469             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2470      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2471 C Derivatives in DC(i+1)
2472             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2473      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2474             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2475      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2476             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2477      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2478             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2479      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2480 C Derivatives in DC(j)
2481             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2482      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2483             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2484      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2485             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2486      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2487             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2488      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2489 C Derivatives in DC(j+1) or DC(nres-1)
2490             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2491      &      -3.0d0*vryg(k,3)*ury)
2492             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2493      &      -3.0d0*vrzg(k,3)*ury)
2494             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2495      &      -3.0d0*vryg(k,3)*urz)
2496             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2497      &      -3.0d0*vrzg(k,3)*urz)
2498 cd            aggi(k,1)=ghalf1
2499 cd            aggi(k,2)=ghalf2
2500 cd            aggi(k,3)=ghalf3
2501 cd            aggi(k,4)=ghalf4
2502 C Derivatives in DC(i+1)
2503 cd            aggi1(k,1)=agg(k,1)
2504 cd            aggi1(k,2)=agg(k,2)
2505 cd            aggi1(k,3)=agg(k,3)
2506 cd            aggi1(k,4)=agg(k,4)
2507 C Derivatives in DC(j)
2508 cd            aggj(k,1)=ghalf1
2509 cd            aggj(k,2)=ghalf2
2510 cd            aggj(k,3)=ghalf3
2511 cd            aggj(k,4)=ghalf4
2512 C Derivatives in DC(j+1)
2513 cd            aggj1(k,1)=0.0d0
2514 cd            aggj1(k,2)=0.0d0
2515 cd            aggj1(k,3)=0.0d0
2516 cd            aggj1(k,4)=0.0d0
2517             if (j.eq.nres-1 .and. i.lt.j-2) then
2518               do l=1,4
2519                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2520 cd                aggj1(k,l)=agg(k,l)
2521               enddo
2522             endif
2523           enddo
2524           endif
2525 c          goto 11111
2526 C Check the loc-el terms by numerical integration
2527           acipa(1,1)=a22
2528           acipa(1,2)=a23
2529           acipa(2,1)=a32
2530           acipa(2,2)=a33
2531           a22=-a22
2532           a23=-a23
2533           do l=1,2
2534             do k=1,3
2535               agg(k,l)=-agg(k,l)
2536               aggi(k,l)=-aggi(k,l)
2537               aggi1(k,l)=-aggi1(k,l)
2538               aggj(k,l)=-aggj(k,l)
2539               aggj1(k,l)=-aggj1(k,l)
2540             enddo
2541           enddo
2542           if (j.lt.nres-1) then
2543             a22=-a22
2544             a32=-a32
2545             do l=1,3,2
2546               do k=1,3
2547                 agg(k,l)=-agg(k,l)
2548                 aggi(k,l)=-aggi(k,l)
2549                 aggi1(k,l)=-aggi1(k,l)
2550                 aggj(k,l)=-aggj(k,l)
2551                 aggj1(k,l)=-aggj1(k,l)
2552               enddo
2553             enddo
2554           else
2555             a22=-a22
2556             a23=-a23
2557             a32=-a32
2558             a33=-a33
2559             do l=1,4
2560               do k=1,3
2561                 agg(k,l)=-agg(k,l)
2562                 aggi(k,l)=-aggi(k,l)
2563                 aggi1(k,l)=-aggi1(k,l)
2564                 aggj(k,l)=-aggj(k,l)
2565                 aggj1(k,l)=-aggj1(k,l)
2566               enddo
2567             enddo
2568           endif
2569           ENDIF ! WCORR
2570 11111     continue
2571           IF (wel_loc.gt.0.0d0) THEN
2572 C Contribution to the local-electrostatic energy coming from the i-j pair
2573           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2574      &     +a33*muij(4)
2575 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2576 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2577           if (shield_mode.eq.0) then
2578            fac_shield(i)=1.0
2579            fac_shield(j)=1.0
2580 C          else
2581 C           fac_shield(i)=0.4
2582 C           fac_shield(j)=0.6
2583           endif
2584           eel_loc_ij=eel_loc_ij
2585      &    *fac_shield(i)*fac_shield(j)
2586           eel_loc=eel_loc+eel_loc_ij
2587 C Partial derivatives in virtual-bond dihedral angles gamma
2588           if (calc_grad) then
2589           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2590      &  (shield_mode.gt.0)) then
2591 C          print *,i,j
2592
2593           do ilist=1,ishield_list(i)
2594            iresshield=shield_list(ilist,i)
2595            do k=1,3
2596            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2597      &                                          /fac_shield(i)
2598 C     &      *2.0
2599            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2600      &              rlocshield
2601      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2602             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2603      &      +rlocshield
2604            enddo
2605           enddo
2606           do ilist=1,ishield_list(j)
2607            iresshield=shield_list(ilist,j)
2608            do k=1,3
2609            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2610      &                                       /fac_shield(j)
2611 C     &     *2.0
2612            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2613      &              rlocshield
2614      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2615            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2616      &             +rlocshield
2617
2618            enddo
2619           enddo
2620           do k=1,3
2621             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2622      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2623             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2624      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2625             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2626      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2627             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2628      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2629            enddo
2630            endif
2631           if (i.gt.1)
2632      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2633      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2634      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2635      &    *fac_shield(i)*fac_shield(j)
2636           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2637      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2638      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2639      &    *fac_shield(i)*fac_shield(j)
2640
2641 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2642 cd          write(iout,*) 'agg  ',agg
2643 cd          write(iout,*) 'aggi ',aggi
2644 cd          write(iout,*) 'aggi1',aggi1
2645 cd          write(iout,*) 'aggj ',aggj
2646 cd          write(iout,*) 'aggj1',aggj1
2647
2648 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2649           do l=1,3
2650             ggg(l)=agg(l,1)*muij(1)+
2651      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2652      &    *fac_shield(i)*fac_shield(j)
2653
2654           enddo
2655           do k=i+2,j2
2656             do l=1,3
2657               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2658             enddo
2659           enddo
2660 C Remaining derivatives of eello
2661           do l=1,3
2662             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2663      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2664      &    *fac_shield(i)*fac_shield(j)
2665
2666             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2667      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2668      &    *fac_shield(i)*fac_shield(j)
2669
2670             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2671      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2672      &    *fac_shield(i)*fac_shield(j)
2673
2674             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2675      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2676      &    *fac_shield(i)*fac_shield(j)
2677
2678           enddo
2679           endif
2680           ENDIF
2681           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2682 C Contributions from turns
2683             a_temp(1,1)=a22
2684             a_temp(1,2)=a23
2685             a_temp(2,1)=a32
2686             a_temp(2,2)=a33
2687             call eturn34(i,j,eello_turn3,eello_turn4)
2688           endif
2689 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2690           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2691 C
2692 C Calculate the contact function. The ith column of the array JCONT will
2693 C contain the numbers of atoms that make contacts with the atom I (of numbers
2694 C greater than I). The arrays FACONT and GACONT will contain the values of
2695 C the contact function and its derivative.
2696 c           r0ij=1.02D0*rpp(iteli,itelj)
2697 c           r0ij=1.11D0*rpp(iteli,itelj)
2698             r0ij=2.20D0*rpp(iteli,itelj)
2699 c           r0ij=1.55D0*rpp(iteli,itelj)
2700             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2701             if (fcont.gt.0.0D0) then
2702               num_conti=num_conti+1
2703               if (num_conti.gt.maxconts) then
2704                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2705      &                         ' will skip next contacts for this conf.'
2706               else
2707                 jcont_hb(num_conti,i)=j
2708                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2709      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2710 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2711 C  terms.
2712                 d_cont(num_conti,i)=rij
2713 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2714 C     --- Electrostatic-interaction matrix ---
2715                 a_chuj(1,1,num_conti,i)=a22
2716                 a_chuj(1,2,num_conti,i)=a23
2717                 a_chuj(2,1,num_conti,i)=a32
2718                 a_chuj(2,2,num_conti,i)=a33
2719 C     --- Gradient of rij
2720                 do kkk=1,3
2721                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2722                 enddo
2723 c             if (i.eq.1) then
2724 c                a_chuj(1,1,num_conti,i)=-0.61d0
2725 c                a_chuj(1,2,num_conti,i)= 0.4d0
2726 c                a_chuj(2,1,num_conti,i)= 0.65d0
2727 c                a_chuj(2,2,num_conti,i)= 0.50d0
2728 c             else if (i.eq.2) then
2729 c                a_chuj(1,1,num_conti,i)= 0.0d0
2730 c                a_chuj(1,2,num_conti,i)= 0.0d0
2731 c                a_chuj(2,1,num_conti,i)= 0.0d0
2732 c                a_chuj(2,2,num_conti,i)= 0.0d0
2733 c             endif
2734 C     --- and its gradients
2735 cd                write (iout,*) 'i',i,' j',j
2736 cd                do kkk=1,3
2737 cd                write (iout,*) 'iii 1 kkk',kkk
2738 cd                write (iout,*) agg(kkk,:)
2739 cd                enddo
2740 cd                do kkk=1,3
2741 cd                write (iout,*) 'iii 2 kkk',kkk
2742 cd                write (iout,*) aggi(kkk,:)
2743 cd                enddo
2744 cd                do kkk=1,3
2745 cd                write (iout,*) 'iii 3 kkk',kkk
2746 cd                write (iout,*) aggi1(kkk,:)
2747 cd                enddo
2748 cd                do kkk=1,3
2749 cd                write (iout,*) 'iii 4 kkk',kkk
2750 cd                write (iout,*) aggj(kkk,:)
2751 cd                enddo
2752 cd                do kkk=1,3
2753 cd                write (iout,*) 'iii 5 kkk',kkk
2754 cd                write (iout,*) aggj1(kkk,:)
2755 cd                enddo
2756                 kkll=0
2757                 do k=1,2
2758                   do l=1,2
2759                     kkll=kkll+1
2760                     do m=1,3
2761                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2762                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2763                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2764                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2765                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2766 c                      do mm=1,5
2767 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2768 c                      enddo
2769                     enddo
2770                   enddo
2771                 enddo
2772                 ENDIF
2773                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2774 C Calculate contact energies
2775                 cosa4=4.0D0*cosa
2776                 wij=cosa-3.0D0*cosb*cosg
2777                 cosbg1=cosb+cosg
2778                 cosbg2=cosb-cosg
2779 c               fac3=dsqrt(-ael6i)/r0ij**3
2780                 fac3=dsqrt(-ael6i)*r3ij
2781                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2782                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2783                 if (shield_mode.eq.0) then
2784                 fac_shield(i)=1.0d0
2785                 fac_shield(j)=1.0d0
2786                 else
2787                 ees0plist(num_conti,i)=j
2788 C                fac_shield(i)=0.4d0
2789 C                fac_shield(j)=0.6d0
2790                 endif
2791 c               ees0mij=0.0D0
2792                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2793      &          *fac_shield(i)*fac_shield(j)
2794
2795                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2796      &          *fac_shield(i)*fac_shield(j)
2797
2798 C Diagnostics. Comment out or remove after debugging!
2799 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2800 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2801 c               ees0m(num_conti,i)=0.0D0
2802 C End diagnostics.
2803 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2804 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2805                 facont_hb(num_conti,i)=fcont
2806                 if (calc_grad) then
2807 C Angular derivatives of the contact function
2808                 ees0pij1=fac3/ees0pij
2809                 ees0mij1=fac3/ees0mij
2810                 fac3p=-3.0D0*fac3*rrmij
2811                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2812                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2813 c               ees0mij1=0.0D0
2814                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2815                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2816                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2817                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2818                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2819                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2820                 ecosap=ecosa1+ecosa2
2821                 ecosbp=ecosb1+ecosb2
2822                 ecosgp=ecosg1+ecosg2
2823                 ecosam=ecosa1-ecosa2
2824                 ecosbm=ecosb1-ecosb2
2825                 ecosgm=ecosg1-ecosg2
2826 C Diagnostics
2827 c               ecosap=ecosa1
2828 c               ecosbp=ecosb1
2829 c               ecosgp=ecosg1
2830 c               ecosam=0.0D0
2831 c               ecosbm=0.0D0
2832 c               ecosgm=0.0D0
2833 C End diagnostics
2834                 fprimcont=fprimcont/rij
2835 cd              facont_hb(num_conti,i)=1.0D0
2836 C Following line is for diagnostics.
2837 cd              fprimcont=0.0D0
2838                 do k=1,3
2839                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2840                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2841                 enddo
2842                 do k=1,3
2843                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2844                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2845                 enddo
2846                 gggp(1)=gggp(1)+ees0pijp*xj
2847                 gggp(2)=gggp(2)+ees0pijp*yj
2848                 gggp(3)=gggp(3)+ees0pijp*zj
2849                 gggm(1)=gggm(1)+ees0mijp*xj
2850                 gggm(2)=gggm(2)+ees0mijp*yj
2851                 gggm(3)=gggm(3)+ees0mijp*zj
2852 C Derivatives due to the contact function
2853                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2854                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2855                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2856                 do k=1,3
2857                   ghalfp=0.5D0*gggp(k)
2858                   ghalfm=0.5D0*gggm(k)
2859                   gacontp_hb1(k,num_conti,i)=ghalfp
2860      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2861      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2862      &          *fac_shield(i)*fac_shield(j)
2863
2864                   gacontp_hb2(k,num_conti,i)=ghalfp
2865      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2866      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2867      &          *fac_shield(i)*fac_shield(j)
2868
2869                   gacontp_hb3(k,num_conti,i)=gggp(k)
2870      &          *fac_shield(i)*fac_shield(j)
2871
2872                   gacontm_hb1(k,num_conti,i)=ghalfm
2873      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2874      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2875      &          *fac_shield(i)*fac_shield(j)
2876
2877                   gacontm_hb2(k,num_conti,i)=ghalfm
2878      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2879      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2880      &          *fac_shield(i)*fac_shield(j)
2881
2882                   gacontm_hb3(k,num_conti,i)=gggm(k)
2883      &          *fac_shield(i)*fac_shield(j)
2884
2885                 enddo
2886                 endif
2887 C Diagnostics. Comment out or remove after debugging!
2888 cdiag           do k=1,3
2889 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2890 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2891 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2892 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2893 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2894 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2895 cdiag           enddo
2896               ENDIF ! wcorr
2897               endif  ! num_conti.le.maxconts
2898             endif  ! fcont.gt.0
2899           endif    ! j.gt.i+1
2900  1216     continue
2901         enddo ! j
2902         num_cont_hb(i)=num_conti
2903  1215   continue
2904       enddo   ! i
2905 cd      do i=1,nres
2906 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2907 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2908 cd      enddo
2909 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2910 ccc      eel_loc=eel_loc+eello_turn3
2911       return
2912       end
2913 C-----------------------------------------------------------------------------
2914       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2915 C Third- and fourth-order contributions from turns
2916       implicit real*8 (a-h,o-z)
2917       include 'DIMENSIONS'
2918       include 'sizesclu.dat'
2919       include 'COMMON.IOUNITS'
2920       include 'COMMON.GEO'
2921       include 'COMMON.VAR'
2922       include 'COMMON.LOCAL'
2923       include 'COMMON.CHAIN'
2924       include 'COMMON.DERIV'
2925       include 'COMMON.INTERACT'
2926       include 'COMMON.CONTACTS'
2927       include 'COMMON.TORSION'
2928       include 'COMMON.VECTORS'
2929       include 'COMMON.FFIELD'
2930       include 'COMMON.SHIELD'
2931
2932       dimension ggg(3)
2933       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2934      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2935      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2936       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2937      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2938       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2939       if (j.eq.i+2) then
2940       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2941 C changes suggested by Ana to avoid out of bounds
2942 C     & .or.((i+5).gt.nres)
2943 C     & .or.((i-1).le.0)
2944 C end of changes suggested by Ana
2945      &    .or. itype(i+2).eq.ntyp1
2946      &    .or. itype(i+3).eq.ntyp1
2947 C     &    .or. itype(i+5).eq.ntyp1
2948 C     &    .or. itype(i).eq.ntyp1
2949 C     &    .or. itype(i-1).eq.ntyp1
2950      &    ) goto 179
2951
2952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2953 C
2954 C               Third-order contributions
2955 C
2956 C                 (i+2)o----(i+3)
2957 C                      | |
2958 C                      | |
2959 C                 (i+1)o----i
2960 C
2961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2962 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2963         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2964         call transpose2(auxmat(1,1),auxmat1(1,1))
2965         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2966         if (shield_mode.eq.0) then
2967         fac_shield(i)=1.0
2968         fac_shield(j)=1.0
2969 C        else
2970 C        fac_shield(i)=0.4
2971 C        fac_shield(j)=0.6
2972         endif
2973         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2974      &  *fac_shield(i)*fac_shield(j)
2975         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
2976      &  *fac_shield(i)*fac_shield(j)
2977
2978 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2979 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2980 cd     &    ' eello_turn3_num',4*eello_turn3_num
2981         if (calc_grad) then
2982 C Derivatives in shield mode
2983           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2984      &  (shield_mode.gt.0)) then
2985 C          print *,i,j
2986
2987           do ilist=1,ishield_list(i)
2988            iresshield=shield_list(ilist,i)
2989            do k=1,3
2990            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
2991 C     &      *2.0
2992            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
2993      &              rlocshield
2994      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
2995             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
2996      &      +rlocshield
2997            enddo
2998           enddo
2999           do ilist=1,ishield_list(j)
3000            iresshield=shield_list(ilist,j)
3001            do k=1,3
3002            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3003 C     &     *2.0
3004            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3005      &              rlocshield
3006      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3007            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3008      &             +rlocshield
3009
3010            enddo
3011           enddo
3012
3013           do k=1,3
3014             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3015      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3016             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3017      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3018             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3019      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3020             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3021      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3022            enddo
3023            endif
3024
3025 C Derivatives in gamma(i)
3026         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3027         call transpose2(auxmat2(1,1),pizda(1,1))
3028         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3029         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3030      &   *fac_shield(i)*fac_shield(j)
3031
3032 C Derivatives in gamma(i+1)
3033         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3034         call transpose2(auxmat2(1,1),pizda(1,1))
3035         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3036         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3037      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3038      &   *fac_shield(i)*fac_shield(j)
3039
3040 C Cartesian derivatives
3041         do l=1,3
3042           a_temp(1,1)=aggi(l,1)
3043           a_temp(1,2)=aggi(l,2)
3044           a_temp(2,1)=aggi(l,3)
3045           a_temp(2,2)=aggi(l,4)
3046           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3047           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3048      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3049      &   *fac_shield(i)*fac_shield(j)
3050
3051           a_temp(1,1)=aggi1(l,1)
3052           a_temp(1,2)=aggi1(l,2)
3053           a_temp(2,1)=aggi1(l,3)
3054           a_temp(2,2)=aggi1(l,4)
3055           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3056           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3057      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3058      &   *fac_shield(i)*fac_shield(j)
3059
3060           a_temp(1,1)=aggj(l,1)
3061           a_temp(1,2)=aggj(l,2)
3062           a_temp(2,1)=aggj(l,3)
3063           a_temp(2,2)=aggj(l,4)
3064           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3065           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3066      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3067      &   *fac_shield(i)*fac_shield(j)
3068
3069           a_temp(1,1)=aggj1(l,1)
3070           a_temp(1,2)=aggj1(l,2)
3071           a_temp(2,1)=aggj1(l,3)
3072           a_temp(2,2)=aggj1(l,4)
3073           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3074           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3075      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3076      &   *fac_shield(i)*fac_shield(j)
3077
3078         enddo
3079         endif
3080   179 continue
3081       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3082       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3083 C changes suggested by Ana to avoid out of bounds
3084 C     & .or.((i+5).gt.nres)
3085 C     & .or.((i-1).le.0)
3086 C end of changes suggested by Ana
3087      &    .or. itype(i+3).eq.ntyp1
3088      &    .or. itype(i+4).eq.ntyp1
3089 C     &    .or. itype(i+5).eq.ntyp1
3090      &    .or. itype(i).eq.ntyp1
3091 C     &    .or. itype(i-1).eq.ntyp1
3092      &    ) goto 178
3093
3094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3095 C
3096 C               Fourth-order contributions
3097 C
3098 C                 (i+3)o----(i+4)
3099 C                     /  |
3100 C               (i+2)o   |
3101 C                     \  |
3102 C                 (i+1)o----i
3103 C
3104 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3105 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3106         iti1=itortyp(itype(i+1))
3107         iti2=itortyp(itype(i+2))
3108         iti3=itortyp(itype(i+3))
3109         call transpose2(EUg(1,1,i+1),e1t(1,1))
3110         call transpose2(Eug(1,1,i+2),e2t(1,1))
3111         call transpose2(Eug(1,1,i+3),e3t(1,1))
3112         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3113         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3114         s1=scalar2(b1(1,iti2),auxvec(1))
3115         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3116         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3117         s2=scalar2(b1(1,iti1),auxvec(1))
3118         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3119         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3120         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3121         if (shield_mode.eq.0) then
3122         fac_shield(i)=1.0
3123         fac_shield(j)=1.0
3124 C        else
3125 C        fac_shield(i)=0.4
3126 C        fac_shield(j)=0.6
3127         endif
3128         eello_turn4=eello_turn4-(s1+s2+s3)
3129      &  *fac_shield(i)*fac_shield(j)
3130         eello_t4=-(s1+s2+s3)
3131      &  *fac_shield(i)*fac_shield(j)
3132
3133 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3134 cd     &    ' eello_turn4_num',8*eello_turn4_num
3135 C Derivatives in gamma(i)
3136         if (calc_grad) then
3137           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3138      &  (shield_mode.gt.0)) then
3139 C          print *,i,j
3140
3141           do ilist=1,ishield_list(i)
3142            iresshield=shield_list(ilist,i)
3143            do k=1,3
3144            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3145 C     &      *2.0
3146            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3147      &              rlocshield
3148      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3149             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3150      &      +rlocshield
3151            enddo
3152           enddo
3153           do ilist=1,ishield_list(j)
3154            iresshield=shield_list(ilist,j)
3155            do k=1,3
3156            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3157 C     &     *2.0
3158            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3159      &              rlocshield
3160      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3161            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3162      &             +rlocshield
3163
3164            enddo
3165           enddo
3166
3167           do k=1,3
3168             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3169      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3170             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3171      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3172             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3173      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3174             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3175      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3176            enddo
3177            endif
3178
3179         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3180         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3181         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3182         s1=scalar2(b1(1,iti2),auxvec(1))
3183         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3184         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3185         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3186      &  *fac_shield(i)*fac_shield(j)
3187
3188 C Derivatives in gamma(i+1)
3189         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3190         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3191         s2=scalar2(b1(1,iti1),auxvec(1))
3192         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3193         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3194         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3195         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3196      &  *fac_shield(i)*fac_shield(j)
3197
3198 C Derivatives in gamma(i+2)
3199         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3200         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3201         s1=scalar2(b1(1,iti2),auxvec(1))
3202         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3203         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3204         s2=scalar2(b1(1,iti1),auxvec(1))
3205         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3206         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3207         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3208         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3209      &  *fac_shield(i)*fac_shield(j)
3210
3211 C Cartesian derivatives
3212 C Derivatives of this turn contributions in DC(i+2)
3213         if (j.lt.nres-1) then
3214           do l=1,3
3215             a_temp(1,1)=agg(l,1)
3216             a_temp(1,2)=agg(l,2)
3217             a_temp(2,1)=agg(l,3)
3218             a_temp(2,2)=agg(l,4)
3219             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3220             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3221             s1=scalar2(b1(1,iti2),auxvec(1))
3222             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3223             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3224             s2=scalar2(b1(1,iti1),auxvec(1))
3225             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3226             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3227             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3228             ggg(l)=-(s1+s2+s3)
3229             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3230      &  *fac_shield(i)*fac_shield(j)
3231
3232           enddo
3233         endif
3234 C Remaining derivatives of this turn contribution
3235         do l=1,3
3236           a_temp(1,1)=aggi(l,1)
3237           a_temp(1,2)=aggi(l,2)
3238           a_temp(2,1)=aggi(l,3)
3239           a_temp(2,2)=aggi(l,4)
3240           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3241           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3242           s1=scalar2(b1(1,iti2),auxvec(1))
3243           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3244           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3245           s2=scalar2(b1(1,iti1),auxvec(1))
3246           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3247           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3248           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3249           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3250      &  *fac_shield(i)*fac_shield(j)
3251
3252           a_temp(1,1)=aggi1(l,1)
3253           a_temp(1,2)=aggi1(l,2)
3254           a_temp(2,1)=aggi1(l,3)
3255           a_temp(2,2)=aggi1(l,4)
3256           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3257           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3258           s1=scalar2(b1(1,iti2),auxvec(1))
3259           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3260           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3261           s2=scalar2(b1(1,iti1),auxvec(1))
3262           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3263           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3264           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3265           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3266      &  *fac_shield(i)*fac_shield(j)
3267
3268           a_temp(1,1)=aggj(l,1)
3269           a_temp(1,2)=aggj(l,2)
3270           a_temp(2,1)=aggj(l,3)
3271           a_temp(2,2)=aggj(l,4)
3272           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3273           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3274           s1=scalar2(b1(1,iti2),auxvec(1))
3275           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3276           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3277           s2=scalar2(b1(1,iti1),auxvec(1))
3278           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3279           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3280           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3281           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3282      &  *fac_shield(i)*fac_shield(j)
3283
3284           a_temp(1,1)=aggj1(l,1)
3285           a_temp(1,2)=aggj1(l,2)
3286           a_temp(2,1)=aggj1(l,3)
3287           a_temp(2,2)=aggj1(l,4)
3288           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3289           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3290           s1=scalar2(b1(1,iti2),auxvec(1))
3291           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3292           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3293           s2=scalar2(b1(1,iti1),auxvec(1))
3294           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3295           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3296           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3297           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3298      &  *fac_shield(i)*fac_shield(j)
3299
3300         enddo
3301         endif
3302   178 continue
3303       endif
3304       return
3305       end
3306 C-----------------------------------------------------------------------------
3307       subroutine vecpr(u,v,w)
3308       implicit real*8(a-h,o-z)
3309       dimension u(3),v(3),w(3)
3310       w(1)=u(2)*v(3)-u(3)*v(2)
3311       w(2)=-u(1)*v(3)+u(3)*v(1)
3312       w(3)=u(1)*v(2)-u(2)*v(1)
3313       return
3314       end
3315 C-----------------------------------------------------------------------------
3316       subroutine unormderiv(u,ugrad,unorm,ungrad)
3317 C This subroutine computes the derivatives of a normalized vector u, given
3318 C the derivatives computed without normalization conditions, ugrad. Returns
3319 C ungrad.
3320       implicit none
3321       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3322       double precision vec(3)
3323       double precision scalar
3324       integer i,j
3325 c      write (2,*) 'ugrad',ugrad
3326 c      write (2,*) 'u',u
3327       do i=1,3
3328         vec(i)=scalar(ugrad(1,i),u(1))
3329       enddo
3330 c      write (2,*) 'vec',vec
3331       do i=1,3
3332         do j=1,3
3333           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3334         enddo
3335       enddo
3336 c      write (2,*) 'ungrad',ungrad
3337       return
3338       end
3339 C-----------------------------------------------------------------------------
3340       subroutine escp(evdw2,evdw2_14)
3341 C
3342 C This subroutine calculates the excluded-volume interaction energy between
3343 C peptide-group centers and side chains and its gradient in virtual-bond and
3344 C side-chain vectors.
3345 C
3346       implicit real*8 (a-h,o-z)
3347       include 'DIMENSIONS'
3348       include 'sizesclu.dat'
3349       include 'COMMON.GEO'
3350       include 'COMMON.VAR'
3351       include 'COMMON.LOCAL'
3352       include 'COMMON.CHAIN'
3353       include 'COMMON.DERIV'
3354       include 'COMMON.INTERACT'
3355       include 'COMMON.FFIELD'
3356       include 'COMMON.IOUNITS'
3357       dimension ggg(3)
3358       evdw2=0.0D0
3359       evdw2_14=0.0d0
3360 cd    print '(a)','Enter ESCP'
3361 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3362 c     &  ' scal14',scal14
3363       do i=iatscp_s,iatscp_e
3364         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3365         iteli=itel(i)
3366 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3367 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3368         if (iteli.eq.0) goto 1225
3369         xi=0.5D0*(c(1,i)+c(1,i+1))
3370         yi=0.5D0*(c(2,i)+c(2,i+1))
3371         zi=0.5D0*(c(3,i)+c(3,i+1))
3372 C    Returning the ith atom to box
3373           xi=mod(xi,boxxsize)
3374           if (xi.lt.0) xi=xi+boxxsize
3375           yi=mod(yi,boxysize)
3376           if (yi.lt.0) yi=yi+boxysize
3377           zi=mod(zi,boxzsize)
3378           if (zi.lt.0) zi=zi+boxzsize
3379
3380         do iint=1,nscp_gr(i)
3381
3382         do j=iscpstart(i,iint),iscpend(i,iint)
3383           itypj=iabs(itype(j))
3384           if (itypj.eq.ntyp1) cycle
3385 C Uncomment following three lines for SC-p interactions
3386 c         xj=c(1,nres+j)-xi
3387 c         yj=c(2,nres+j)-yi
3388 c         zj=c(3,nres+j)-zi
3389 C Uncomment following three lines for Ca-p interactions
3390           xj=c(1,j)
3391           yj=c(2,j)
3392           zj=c(3,j)
3393 C returning the jth atom to box
3394           xj=mod(xj,boxxsize)
3395           if (xj.lt.0) xj=xj+boxxsize
3396           yj=mod(yj,boxysize)
3397           if (yj.lt.0) yj=yj+boxysize
3398           zj=mod(zj,boxzsize)
3399           if (zj.lt.0) zj=zj+boxzsize
3400       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3401       xj_safe=xj
3402       yj_safe=yj
3403       zj_safe=zj
3404       subchap=0
3405 C Finding the closest jth atom
3406       do xshift=-1,1
3407       do yshift=-1,1
3408       do zshift=-1,1
3409           xj=xj_safe+xshift*boxxsize
3410           yj=yj_safe+yshift*boxysize
3411           zj=zj_safe+zshift*boxzsize
3412           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3413           if(dist_temp.lt.dist_init) then
3414             dist_init=dist_temp
3415             xj_temp=xj
3416             yj_temp=yj
3417             zj_temp=zj
3418             subchap=1
3419           endif
3420        enddo
3421        enddo
3422        enddo
3423        if (subchap.eq.1) then
3424           xj=xj_temp-xi
3425           yj=yj_temp-yi
3426           zj=zj_temp-zi
3427        else
3428           xj=xj_safe-xi
3429           yj=yj_safe-yi
3430           zj=zj_safe-zi
3431        endif
3432
3433           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3434 C sss is scaling function for smoothing the cutoff gradient otherwise
3435 C the gradient would not be continuouse
3436           sss=sscale(1.0d0/(dsqrt(rrij)))
3437           if (sss.le.0.0d0) cycle
3438           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3439           fac=rrij**expon2
3440           e1=fac*fac*aad(itypj,iteli)
3441           e2=fac*bad(itypj,iteli)
3442           if (iabs(j-i) .le. 2) then
3443             e1=scal14*e1
3444             e2=scal14*e2
3445             evdw2_14=evdw2_14+(e1+e2)*sss
3446           endif
3447           evdwij=e1+e2
3448 c          write (iout,*) i,j,evdwij
3449           evdw2=evdw2+evdwij*sss
3450           if (calc_grad) then
3451 C
3452 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3453 C
3454            fac=-(evdwij+e1)*rrij*sss
3455            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3456           ggg(1)=xj*fac
3457           ggg(2)=yj*fac
3458           ggg(3)=zj*fac
3459           if (j.lt.i) then
3460 cd          write (iout,*) 'j<i'
3461 C Uncomment following three lines for SC-p interactions
3462 c           do k=1,3
3463 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3464 c           enddo
3465           else
3466 cd          write (iout,*) 'j>i'
3467             do k=1,3
3468               ggg(k)=-ggg(k)
3469 C Uncomment following line for SC-p interactions
3470 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3471             enddo
3472           endif
3473           do k=1,3
3474             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3475           enddo
3476           kstart=min0(i+1,j)
3477           kend=max0(i-1,j-1)
3478 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3479 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3480           do k=kstart,kend
3481             do l=1,3
3482               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3483             enddo
3484           enddo
3485           endif
3486         enddo
3487         enddo ! iint
3488  1225   continue
3489       enddo ! i
3490       do i=1,nct
3491         do j=1,3
3492           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3493           gradx_scp(j,i)=expon*gradx_scp(j,i)
3494         enddo
3495       enddo
3496 C******************************************************************************
3497 C
3498 C                              N O T E !!!
3499 C
3500 C To save time the factor EXPON has been extracted from ALL components
3501 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3502 C use!
3503 C
3504 C******************************************************************************
3505       return
3506       end
3507 C--------------------------------------------------------------------------
3508       subroutine edis(ehpb)
3509 C
3510 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3511 C
3512       implicit real*8 (a-h,o-z)
3513       include 'DIMENSIONS'
3514       include 'sizesclu.dat'
3515       include 'COMMON.SBRIDGE'
3516       include 'COMMON.CHAIN'
3517       include 'COMMON.DERIV'
3518       include 'COMMON.VAR'
3519       include 'COMMON.INTERACT'
3520       include 'COMMON.CONTROL'
3521       dimension ggg(3)
3522       ehpb=0.0D0
3523 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3524 cd    print *,'link_start=',link_start,' link_end=',link_end
3525       if (link_end.eq.0) return
3526       do i=link_start,link_end
3527 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3528 C CA-CA distance used in regularization of structure.
3529         ii=ihpb(i)
3530         jj=jhpb(i)
3531 C iii and jjj point to the residues for which the distance is assigned.
3532         if (ii.gt.nres) then
3533           iii=ii-nres
3534           jjj=jj-nres
3535         else
3536           iii=ii
3537           jjj=jj
3538         endif
3539 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3540 C    distance and angle dependent SS bond potential.
3541 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3542 C     &  iabs(itype(jjj)).eq.1) then
3543 C          call ssbond_ene(iii,jjj,eij)
3544 C          ehpb=ehpb+2*eij
3545 C        else
3546        if (.not.dyn_ss .and. i.le.nss) then
3547          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3548      & iabs(itype(jjj)).eq.1) then
3549           call ssbond_ene(iii,jjj,eij)
3550           ehpb=ehpb+2*eij
3551            endif !ii.gt.neres
3552         else if (ii.gt.nres .and. jj.gt.nres) then
3553 c Restraints from contact prediction
3554           dd=dist(ii,jj)
3555           if (constr_dist.eq.11) then
3556 C            ehpb=ehpb+fordepth(i)**4.0d0
3557 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3558             ehpb=ehpb+fordepth(i)**4.0d0
3559      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3560             fac=fordepth(i)**4.0d0
3561      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3562 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3563 C     &    ehpb,fordepth(i),dd
3564 C             print *,"TUTU"
3565 C            write(iout,*) ehpb,"atu?"
3566 C            ehpb,"tu?"
3567 C            fac=fordepth(i)**4.0d0
3568 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3569            else !constr_dist.eq.11
3570           if (dhpb1(i).gt.0.0d0) then
3571             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3572             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3573 c            write (iout,*) "beta nmr",
3574 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3575           else !dhpb(i).gt.0.00
3576
3577 C Calculate the distance between the two points and its difference from the
3578 C target distance.
3579         dd=dist(ii,jj)
3580         rdis=dd-dhpb(i)
3581 C Get the force constant corresponding to this distance.
3582         waga=forcon(i)
3583 C Calculate the contribution to energy.
3584         ehpb=ehpb+waga*rdis*rdis
3585 C
3586 C Evaluate gradient.
3587 C
3588         fac=waga*rdis/dd
3589         endif !dhpb(i).gt.0
3590         endif
3591 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3592 cd   &   ' waga=',waga,' fac=',fac
3593         do j=1,3
3594           ggg(j)=fac*(c(j,jj)-c(j,ii))
3595         enddo
3596 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3597 C If this is a SC-SC distance, we need to calculate the contributions to the
3598 C Cartesian gradient in the SC vectors (ghpbx).
3599         if (iii.lt.ii) then
3600           do j=1,3
3601             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3602             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3603           enddo
3604         endif
3605         else !ii.gt.nres
3606 C          write(iout,*) "before"
3607           dd=dist(ii,jj)
3608 C          write(iout,*) "after",dd
3609           if (constr_dist.eq.11) then
3610             ehpb=ehpb+fordepth(i)**4.0d0
3611      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3612             fac=fordepth(i)**4.0d0
3613      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3614 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3615 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3616 C            print *,ehpb,"tu?"
3617 C            write(iout,*) ehpb,"btu?",
3618 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3619 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3620 C     &    ehpb,fordepth(i),dd
3621            else
3622           if (dhpb1(i).gt.0.0d0) then
3623             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3624             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3625 c            write (iout,*) "alph nmr",
3626 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3627           else
3628             rdis=dd-dhpb(i)
3629 C Get the force constant corresponding to this distance.
3630             waga=forcon(i)
3631 C Calculate the contribution to energy.
3632             ehpb=ehpb+waga*rdis*rdis
3633 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3634 C
3635 C Evaluate gradient.
3636 C
3637             fac=waga*rdis/dd
3638           endif
3639           endif
3640         do j=1,3
3641           ggg(j)=fac*(c(j,jj)-c(j,ii))
3642         enddo
3643 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3644 C If this is a SC-SC distance, we need to calculate the contributions to the
3645 C Cartesian gradient in the SC vectors (ghpbx).
3646         if (iii.lt.ii) then
3647           do j=1,3
3648             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3649             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3650           enddo
3651         endif
3652         do j=iii,jjj-1
3653           do k=1,3
3654             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3655           enddo
3656         enddo
3657         endif
3658       enddo
3659       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3660       return
3661       end
3662 C--------------------------------------------------------------------------
3663       subroutine ssbond_ene(i,j,eij)
3664 C
3665 C Calculate the distance and angle dependent SS-bond potential energy
3666 C using a free-energy function derived based on RHF/6-31G** ab initio
3667 C calculations of diethyl disulfide.
3668 C
3669 C A. Liwo and U. Kozlowska, 11/24/03
3670 C
3671       implicit real*8 (a-h,o-z)
3672       include 'DIMENSIONS'
3673       include 'sizesclu.dat'
3674       include 'COMMON.SBRIDGE'
3675       include 'COMMON.CHAIN'
3676       include 'COMMON.DERIV'
3677       include 'COMMON.LOCAL'
3678       include 'COMMON.INTERACT'
3679       include 'COMMON.VAR'
3680       include 'COMMON.IOUNITS'
3681       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3682       itypi=iabs(itype(i))
3683       xi=c(1,nres+i)
3684       yi=c(2,nres+i)
3685       zi=c(3,nres+i)
3686       dxi=dc_norm(1,nres+i)
3687       dyi=dc_norm(2,nres+i)
3688       dzi=dc_norm(3,nres+i)
3689       dsci_inv=dsc_inv(itypi)
3690       itypj=iabs(itype(j))
3691       dscj_inv=dsc_inv(itypj)
3692       xj=c(1,nres+j)-xi
3693       yj=c(2,nres+j)-yi
3694       zj=c(3,nres+j)-zi
3695       dxj=dc_norm(1,nres+j)
3696       dyj=dc_norm(2,nres+j)
3697       dzj=dc_norm(3,nres+j)
3698       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3699       rij=dsqrt(rrij)
3700       erij(1)=xj*rij
3701       erij(2)=yj*rij
3702       erij(3)=zj*rij
3703       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3704       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3705       om12=dxi*dxj+dyi*dyj+dzi*dzj
3706       do k=1,3
3707         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3708         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3709       enddo
3710       rij=1.0d0/rij
3711       deltad=rij-d0cm
3712       deltat1=1.0d0-om1
3713       deltat2=1.0d0+om2
3714       deltat12=om2-om1+2.0d0
3715       cosphi=om12-om1*om2
3716       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3717      &  +akct*deltad*deltat12
3718      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3719 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3720 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3721 c     &  " deltat12",deltat12," eij",eij
3722       ed=2*akcm*deltad+akct*deltat12
3723       pom1=akct*deltad
3724       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3725       eom1=-2*akth*deltat1-pom1-om2*pom2
3726       eom2= 2*akth*deltat2+pom1-om1*pom2
3727       eom12=pom2
3728       do k=1,3
3729         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3730       enddo
3731       do k=1,3
3732         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3733      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3734         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3735      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3736       enddo
3737 C
3738 C Calculate the components of the gradient in DC and X
3739 C
3740       do k=i,j-1
3741         do l=1,3
3742           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3743         enddo
3744       enddo
3745       return
3746       end
3747 C--------------------------------------------------------------------------
3748       subroutine ebond(estr)
3749 c
3750 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3751 c
3752       implicit real*8 (a-h,o-z)
3753       include 'DIMENSIONS'
3754       include 'sizesclu.dat'
3755       include 'COMMON.LOCAL'
3756       include 'COMMON.GEO'
3757       include 'COMMON.INTERACT'
3758       include 'COMMON.DERIV'
3759       include 'COMMON.VAR'
3760       include 'COMMON.CHAIN'
3761       include 'COMMON.IOUNITS'
3762       include 'COMMON.NAMES'
3763       include 'COMMON.FFIELD'
3764       include 'COMMON.CONTROL'
3765       logical energy_dec /.false./
3766       double precision u(3),ud(3)
3767       estr=0.0d0
3768       estr1=0.0d0
3769       do i=nnt+1,nct
3770         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3771 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3772 C          do j=1,3
3773 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3774 C     &      *dc(j,i-1)/vbld(i)
3775 C          enddo
3776 C          if (energy_dec) write(iout,*)
3777 C     &       "estr1",i,vbld(i),distchainmax,
3778 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3779 C        else
3780          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3781         diff = vbld(i)-vbldpDUM
3782          else
3783           diff = vbld(i)-vbldp0
3784 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3785          endif
3786           estr=estr+diff*diff
3787           do j=1,3
3788             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3789           enddo
3790 C        endif
3791 C        write (iout,'(a7,i5,4f7.3)')
3792 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3793       enddo
3794       estr=0.5d0*AKP*estr+estr1
3795 c
3796 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3797 c
3798       do i=nnt,nct
3799         iti=iabs(itype(i))
3800         if (iti.ne.10 .and. iti.ne.ntyp1) then
3801           nbi=nbondterm(iti)
3802           if (nbi.eq.1) then
3803             diff=vbld(i+nres)-vbldsc0(1,iti)
3804 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3805 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3806             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3807             do j=1,3
3808               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3809             enddo
3810           else
3811             do j=1,nbi
3812               diff=vbld(i+nres)-vbldsc0(j,iti)
3813               ud(j)=aksc(j,iti)*diff
3814               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3815             enddo
3816             uprod=u(1)
3817             do j=2,nbi
3818               uprod=uprod*u(j)
3819             enddo
3820             usum=0.0d0
3821             usumsqder=0.0d0
3822             do j=1,nbi
3823               uprod1=1.0d0
3824               uprod2=1.0d0
3825               do k=1,nbi
3826                 if (k.ne.j) then
3827                   uprod1=uprod1*u(k)
3828                   uprod2=uprod2*u(k)*u(k)
3829                 endif
3830               enddo
3831               usum=usum+uprod1
3832               usumsqder=usumsqder+ud(j)*uprod2
3833             enddo
3834 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3835 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3836             estr=estr+uprod/usum
3837             do j=1,3
3838              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3839             enddo
3840           endif
3841         endif
3842       enddo
3843       return
3844       end
3845 #ifdef CRYST_THETA
3846 C--------------------------------------------------------------------------
3847       subroutine ebend(etheta,ethetacnstr)
3848 C
3849 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3850 C angles gamma and its derivatives in consecutive thetas and gammas.
3851 C
3852       implicit real*8 (a-h,o-z)
3853       include 'DIMENSIONS'
3854       include 'sizesclu.dat'
3855       include 'COMMON.LOCAL'
3856       include 'COMMON.GEO'
3857       include 'COMMON.INTERACT'
3858       include 'COMMON.DERIV'
3859       include 'COMMON.VAR'
3860       include 'COMMON.CHAIN'
3861       include 'COMMON.IOUNITS'
3862       include 'COMMON.NAMES'
3863       include 'COMMON.FFIELD'
3864       include 'COMMON.TORCNSTR'
3865       common /calcthet/ term1,term2,termm,diffak,ratak,
3866      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3867      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3868       double precision y(2),z(2)
3869       delta=0.02d0*pi
3870 c      time11=dexp(-2*time)
3871 c      time12=1.0d0
3872       etheta=0.0D0
3873 c      write (iout,*) "nres",nres
3874 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3875 c      write (iout,*) ithet_start,ithet_end
3876       do i=ithet_start,ithet_end
3877         if (i.le.2) cycle
3878         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3879      &  .or.itype(i).eq.ntyp1) cycle
3880 C Zero the energy function and its derivative at 0 or pi.
3881         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3882         it=itype(i-1)
3883         ichir1=isign(1,itype(i-2))
3884         ichir2=isign(1,itype(i))
3885          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3886          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3887          if (itype(i-1).eq.10) then
3888           itype1=isign(10,itype(i-2))
3889           ichir11=isign(1,itype(i-2))
3890           ichir12=isign(1,itype(i-2))
3891           itype2=isign(10,itype(i))
3892           ichir21=isign(1,itype(i))
3893           ichir22=isign(1,itype(i))
3894          endif
3895          if (i.eq.3) then
3896           y(1)=0.0D0
3897           y(2)=0.0D0
3898           else
3899         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3900 #ifdef OSF
3901           phii=phi(i)
3902 c          icrc=0
3903 c          call proc_proc(phii,icrc)
3904           if (icrc.eq.1) phii=150.0
3905 #else
3906           phii=phi(i)
3907 #endif
3908           y(1)=dcos(phii)
3909           y(2)=dsin(phii)
3910         else
3911           y(1)=0.0D0
3912           y(2)=0.0D0
3913         endif
3914         endif
3915         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3916 #ifdef OSF
3917           phii1=phi(i+1)
3918 c          icrc=0
3919 c          call proc_proc(phii1,icrc)
3920           if (icrc.eq.1) phii1=150.0
3921           phii1=pinorm(phii1)
3922           z(1)=cos(phii1)
3923 #else
3924           phii1=phi(i+1)
3925           z(1)=dcos(phii1)
3926 #endif
3927           z(2)=dsin(phii1)
3928         else
3929           z(1)=0.0D0
3930           z(2)=0.0D0
3931         endif
3932 C Calculate the "mean" value of theta from the part of the distribution
3933 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3934 C In following comments this theta will be referred to as t_c.
3935         thet_pred_mean=0.0d0
3936         do k=1,2
3937             athetk=athet(k,it,ichir1,ichir2)
3938             bthetk=bthet(k,it,ichir1,ichir2)
3939           if (it.eq.10) then
3940              athetk=athet(k,itype1,ichir11,ichir12)
3941              bthetk=bthet(k,itype2,ichir21,ichir22)
3942           endif
3943           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3944         enddo
3945 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3946         dthett=thet_pred_mean*ssd
3947         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3948 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3949 C Derivatives of the "mean" values in gamma1 and gamma2.
3950         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3951      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3952          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3953      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3954          if (it.eq.10) then
3955       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3956      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3957         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3958      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3959          endif
3960         if (theta(i).gt.pi-delta) then
3961           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3962      &         E_tc0)
3963           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3964           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3965           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3966      &        E_theta)
3967           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3968      &        E_tc)
3969         else if (theta(i).lt.delta) then
3970           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3971           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3972           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3973      &        E_theta)
3974           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3975           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3976      &        E_tc)
3977         else
3978           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3979      &        E_theta,E_tc)
3980         endif
3981         etheta=etheta+ethetai
3982 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3983 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3984         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3985         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3986         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3987 c 1215   continue
3988       enddo
3989 C Ufff.... We've done all this!!!
3990 C now constrains
3991       ethetacnstr=0.0d0
3992 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3993       do i=1,ntheta_constr
3994         itheta=itheta_constr(i)
3995         thetiii=theta(itheta)
3996         difi=pinorm(thetiii-theta_constr0(i))
3997         if (difi.gt.theta_drange(i)) then
3998           difi=difi-theta_drange(i)
3999           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4000           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4001      &    +for_thet_constr(i)*difi**3
4002         else if (difi.lt.-drange(i)) then
4003           difi=difi+drange(i)
4004           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4005           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4006      &    +for_thet_constr(i)*difi**3
4007         else
4008           difi=0.0
4009         endif
4010 C       if (energy_dec) then
4011 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4012 C     &    i,itheta,rad2deg*thetiii,
4013 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4014 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4015 C     &    gloc(itheta+nphi-2,icg)
4016 C        endif
4017       enddo
4018       return
4019       end
4020 C---------------------------------------------------------------------------
4021       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4022      &     E_tc)
4023       implicit real*8 (a-h,o-z)
4024       include 'DIMENSIONS'
4025       include 'COMMON.LOCAL'
4026       include 'COMMON.IOUNITS'
4027       common /calcthet/ term1,term2,termm,diffak,ratak,
4028      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4029      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4030 C Calculate the contributions to both Gaussian lobes.
4031 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4032 C The "polynomial part" of the "standard deviation" of this part of
4033 C the distribution.
4034         sig=polthet(3,it)
4035         do j=2,0,-1
4036           sig=sig*thet_pred_mean+polthet(j,it)
4037         enddo
4038 C Derivative of the "interior part" of the "standard deviation of the"
4039 C gamma-dependent Gaussian lobe in t_c.
4040         sigtc=3*polthet(3,it)
4041         do j=2,1,-1
4042           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4043         enddo
4044         sigtc=sig*sigtc
4045 C Set the parameters of both Gaussian lobes of the distribution.
4046 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4047         fac=sig*sig+sigc0(it)
4048         sigcsq=fac+fac
4049         sigc=1.0D0/sigcsq
4050 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4051         sigsqtc=-4.0D0*sigcsq*sigtc
4052 c       print *,i,sig,sigtc,sigsqtc
4053 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4054         sigtc=-sigtc/(fac*fac)
4055 C Following variable is sigma(t_c)**(-2)
4056         sigcsq=sigcsq*sigcsq
4057         sig0i=sig0(it)
4058         sig0inv=1.0D0/sig0i**2
4059         delthec=thetai-thet_pred_mean
4060         delthe0=thetai-theta0i
4061         term1=-0.5D0*sigcsq*delthec*delthec
4062         term2=-0.5D0*sig0inv*delthe0*delthe0
4063 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4064 C NaNs in taking the logarithm. We extract the largest exponent which is added
4065 C to the energy (this being the log of the distribution) at the end of energy
4066 C term evaluation for this virtual-bond angle.
4067         if (term1.gt.term2) then
4068           termm=term1
4069           term2=dexp(term2-termm)
4070           term1=1.0d0
4071         else
4072           termm=term2
4073           term1=dexp(term1-termm)
4074           term2=1.0d0
4075         endif
4076 C The ratio between the gamma-independent and gamma-dependent lobes of
4077 C the distribution is a Gaussian function of thet_pred_mean too.
4078         diffak=gthet(2,it)-thet_pred_mean
4079         ratak=diffak/gthet(3,it)**2
4080         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4081 C Let's differentiate it in thet_pred_mean NOW.
4082         aktc=ak*ratak
4083 C Now put together the distribution terms to make complete distribution.
4084         termexp=term1+ak*term2
4085         termpre=sigc+ak*sig0i
4086 C Contribution of the bending energy from this theta is just the -log of
4087 C the sum of the contributions from the two lobes and the pre-exponential
4088 C factor. Simple enough, isn't it?
4089         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4090 C NOW the derivatives!!!
4091 C 6/6/97 Take into account the deformation.
4092         E_theta=(delthec*sigcsq*term1
4093      &       +ak*delthe0*sig0inv*term2)/termexp
4094         E_tc=((sigtc+aktc*sig0i)/termpre
4095      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4096      &       aktc*term2)/termexp)
4097       return
4098       end
4099 c-----------------------------------------------------------------------------
4100       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4101       implicit real*8 (a-h,o-z)
4102       include 'DIMENSIONS'
4103       include 'COMMON.LOCAL'
4104       include 'COMMON.IOUNITS'
4105       common /calcthet/ term1,term2,termm,diffak,ratak,
4106      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4107      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4108       delthec=thetai-thet_pred_mean
4109       delthe0=thetai-theta0i
4110 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4111       t3 = thetai-thet_pred_mean
4112       t6 = t3**2
4113       t9 = term1
4114       t12 = t3*sigcsq
4115       t14 = t12+t6*sigsqtc
4116       t16 = 1.0d0
4117       t21 = thetai-theta0i
4118       t23 = t21**2
4119       t26 = term2
4120       t27 = t21*t26
4121       t32 = termexp
4122       t40 = t32**2
4123       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4124      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4125      & *(-t12*t9-ak*sig0inv*t27)
4126       return
4127       end
4128 #else
4129 C--------------------------------------------------------------------------
4130       subroutine ebend(etheta,ethetacnstr)
4131 C
4132 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4133 C angles gamma and its derivatives in consecutive thetas and gammas.
4134 C ab initio-derived potentials from
4135 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4136 C
4137       implicit real*8 (a-h,o-z)
4138       include 'DIMENSIONS'
4139       include 'sizesclu.dat'
4140       include 'COMMON.LOCAL'
4141       include 'COMMON.GEO'
4142       include 'COMMON.INTERACT'
4143       include 'COMMON.DERIV'
4144       include 'COMMON.VAR'
4145       include 'COMMON.CHAIN'
4146       include 'COMMON.IOUNITS'
4147       include 'COMMON.NAMES'
4148       include 'COMMON.FFIELD'
4149       include 'COMMON.CONTROL'
4150       include 'COMMON.TORCNSTR'
4151       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4152      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4153      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4154      & sinph1ph2(maxdouble,maxdouble)
4155       logical lprn /.false./, lprn1 /.false./
4156       etheta=0.0D0
4157 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4158       do i=ithet_start,ithet_end
4159         if (i.le.2) cycle
4160         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4161      &  .or.itype(i).eq.ntyp1) cycle
4162 c        if (itype(i-1).eq.ntyp1) cycle
4163         if (iabs(itype(i+1)).eq.20) iblock=2
4164         if (iabs(itype(i+1)).ne.20) iblock=1
4165         dethetai=0.0d0
4166         dephii=0.0d0
4167         dephii1=0.0d0
4168         theti2=0.5d0*theta(i)
4169         ityp2=ithetyp((itype(i-1)))
4170         do k=1,nntheterm
4171           coskt(k)=dcos(k*theti2)
4172           sinkt(k)=dsin(k*theti2)
4173         enddo
4174         if (i.eq.3) then
4175           phii=0.0d0
4176           ityp1=nthetyp+1
4177           do k=1,nsingle
4178             cosph1(k)=0.0d0
4179             sinph1(k)=0.0d0
4180           enddo
4181         else
4182         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4183 #ifdef OSF
4184           phii=phi(i)
4185           if (phii.ne.phii) phii=150.0
4186 #else
4187           phii=phi(i)
4188 #endif
4189           ityp1=ithetyp((itype(i-2)))
4190           do k=1,nsingle
4191             cosph1(k)=dcos(k*phii)
4192             sinph1(k)=dsin(k*phii)
4193           enddo
4194         else
4195           phii=0.0d0
4196 c          ityp1=nthetyp+1
4197           do k=1,nsingle
4198             ityp1=ithetyp((itype(i-2)))
4199             cosph1(k)=0.0d0
4200             sinph1(k)=0.0d0
4201           enddo
4202         endif
4203         endif
4204         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4205 #ifdef OSF
4206           phii1=phi(i+1)
4207           if (phii1.ne.phii1) phii1=150.0
4208           phii1=pinorm(phii1)
4209 #else
4210           phii1=phi(i+1)
4211 #endif
4212           ityp3=ithetyp((itype(i)))
4213           do k=1,nsingle
4214             cosph2(k)=dcos(k*phii1)
4215             sinph2(k)=dsin(k*phii1)
4216           enddo
4217         else
4218           phii1=0.0d0
4219 c          ityp3=nthetyp+1
4220           ityp3=ithetyp((itype(i)))
4221           do k=1,nsingle
4222             cosph2(k)=0.0d0
4223             sinph2(k)=0.0d0
4224           enddo
4225         endif
4226 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4227 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4228 c        call flush(iout)
4229         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4230         do k=1,ndouble
4231           do l=1,k-1
4232             ccl=cosph1(l)*cosph2(k-l)
4233             ssl=sinph1(l)*sinph2(k-l)
4234             scl=sinph1(l)*cosph2(k-l)
4235             csl=cosph1(l)*sinph2(k-l)
4236             cosph1ph2(l,k)=ccl-ssl
4237             cosph1ph2(k,l)=ccl+ssl
4238             sinph1ph2(l,k)=scl+csl
4239             sinph1ph2(k,l)=scl-csl
4240           enddo
4241         enddo
4242         if (lprn) then
4243         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4244      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4245         write (iout,*) "coskt and sinkt"
4246         do k=1,nntheterm
4247           write (iout,*) k,coskt(k),sinkt(k)
4248         enddo
4249         endif
4250         do k=1,ntheterm
4251           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4252           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4253      &      *coskt(k)
4254           if (lprn)
4255      &    write (iout,*) "k",k," aathet",
4256      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4257      &     " ethetai",ethetai
4258         enddo
4259         if (lprn) then
4260         write (iout,*) "cosph and sinph"
4261         do k=1,nsingle
4262           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4263         enddo
4264         write (iout,*) "cosph1ph2 and sinph2ph2"
4265         do k=2,ndouble
4266           do l=1,k-1
4267             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4268      &         sinph1ph2(l,k),sinph1ph2(k,l)
4269           enddo
4270         enddo
4271         write(iout,*) "ethetai",ethetai
4272         endif
4273         do m=1,ntheterm2
4274           do k=1,nsingle
4275             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4276      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4277      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4278      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4279             ethetai=ethetai+sinkt(m)*aux
4280             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4281             dephii=dephii+k*sinkt(m)*(
4282      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4283      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4284             dephii1=dephii1+k*sinkt(m)*(
4285      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4286      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4287             if (lprn)
4288      &      write (iout,*) "m",m," k",k," bbthet",
4289      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4290      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4291      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4292      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4293           enddo
4294         enddo
4295         if (lprn)
4296      &  write(iout,*) "ethetai",ethetai
4297         do m=1,ntheterm3
4298           do k=2,ndouble
4299             do l=1,k-1
4300               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4301      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4302      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4303      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4304               ethetai=ethetai+sinkt(m)*aux
4305               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4306               dephii=dephii+l*sinkt(m)*(
4307      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4308      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4309      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4310      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4311               dephii1=dephii1+(k-l)*sinkt(m)*(
4312      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4313      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4314      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4315      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4316               if (lprn) then
4317               write (iout,*) "m",m," k",k," l",l," ffthet",
4318      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4319      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4320      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4321      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4322      &            " ethetai",ethetai
4323               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4324      &            cosph1ph2(k,l)*sinkt(m),
4325      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4326               endif
4327             enddo
4328           enddo
4329         enddo
4330 10      continue
4331         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4332      &   i,theta(i)*rad2deg,phii*rad2deg,
4333      &   phii1*rad2deg,ethetai
4334         etheta=etheta+ethetai
4335         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4336         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4337 c        gloc(nphi+i-2,icg)=wang*dethetai
4338         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4339       enddo
4340 C now constrains
4341       ethetacnstr=0.0d0
4342 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4343       do i=1,ntheta_constr
4344         itheta=itheta_constr(i)
4345         thetiii=theta(itheta)
4346         difi=pinorm(thetiii-theta_constr0(i))
4347         if (difi.gt.theta_drange(i)) then
4348           difi=difi-theta_drange(i)
4349           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4350           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4351      &    +for_thet_constr(i)*difi**3
4352         else if (difi.lt.-drange(i)) then
4353           difi=difi+drange(i)
4354           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4355           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4356      &    +for_thet_constr(i)*difi**3
4357         else
4358           difi=0.0
4359         endif
4360 C       if (energy_dec) then
4361 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4362 C     &    i,itheta,rad2deg*thetiii,
4363 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4364 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4365 C     &    gloc(itheta+nphi-2,icg)
4366 C        endif
4367       enddo
4368       return
4369       end
4370 #endif
4371 #ifdef CRYST_SC
4372 c-----------------------------------------------------------------------------
4373       subroutine esc(escloc)
4374 C Calculate the local energy of a side chain and its derivatives in the
4375 C corresponding virtual-bond valence angles THETA and the spherical angles
4376 C ALPHA and OMEGA.
4377       implicit real*8 (a-h,o-z)
4378       include 'DIMENSIONS'
4379       include 'sizesclu.dat'
4380       include 'COMMON.GEO'
4381       include 'COMMON.LOCAL'
4382       include 'COMMON.VAR'
4383       include 'COMMON.INTERACT'
4384       include 'COMMON.DERIV'
4385       include 'COMMON.CHAIN'
4386       include 'COMMON.IOUNITS'
4387       include 'COMMON.NAMES'
4388       include 'COMMON.FFIELD'
4389       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4390      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4391       common /sccalc/ time11,time12,time112,theti,it,nlobit
4392       delta=0.02d0*pi
4393       escloc=0.0D0
4394 c     write (iout,'(a)') 'ESC'
4395       do i=loc_start,loc_end
4396         it=itype(i)
4397         if (it.eq.ntyp1) cycle
4398         if (it.eq.10) goto 1
4399         nlobit=nlob(iabs(it))
4400 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4401 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4402         theti=theta(i+1)-pipol
4403         x(1)=dtan(theti)
4404         x(2)=alph(i)
4405         x(3)=omeg(i)
4406 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4407
4408         if (x(2).gt.pi-delta) then
4409           xtemp(1)=x(1)
4410           xtemp(2)=pi-delta
4411           xtemp(3)=x(3)
4412           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4413           xtemp(2)=pi
4414           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4415           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4416      &        escloci,dersc(2))
4417           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4418      &        ddersc0(1),dersc(1))
4419           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4420      &        ddersc0(3),dersc(3))
4421           xtemp(2)=pi-delta
4422           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4423           xtemp(2)=pi
4424           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4425           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4426      &            dersc0(2),esclocbi,dersc02)
4427           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4428      &            dersc12,dersc01)
4429           call splinthet(x(2),0.5d0*delta,ss,ssd)
4430           dersc0(1)=dersc01
4431           dersc0(2)=dersc02
4432           dersc0(3)=0.0d0
4433           do k=1,3
4434             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4435           enddo
4436           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4437 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4438 c    &             esclocbi,ss,ssd
4439           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4440 c         escloci=esclocbi
4441 c         write (iout,*) escloci
4442         else if (x(2).lt.delta) then
4443           xtemp(1)=x(1)
4444           xtemp(2)=delta
4445           xtemp(3)=x(3)
4446           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4447           xtemp(2)=0.0d0
4448           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4449           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4450      &        escloci,dersc(2))
4451           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4452      &        ddersc0(1),dersc(1))
4453           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4454      &        ddersc0(3),dersc(3))
4455           xtemp(2)=delta
4456           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4457           xtemp(2)=0.0d0
4458           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4459           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4460      &            dersc0(2),esclocbi,dersc02)
4461           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4462      &            dersc12,dersc01)
4463           dersc0(1)=dersc01
4464           dersc0(2)=dersc02
4465           dersc0(3)=0.0d0
4466           call splinthet(x(2),0.5d0*delta,ss,ssd)
4467           do k=1,3
4468             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4469           enddo
4470           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4471 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4472 c    &             esclocbi,ss,ssd
4473           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4474 c         write (iout,*) escloci
4475         else
4476           call enesc(x,escloci,dersc,ddummy,.false.)
4477         endif
4478
4479         escloc=escloc+escloci
4480 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4481
4482         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4483      &   wscloc*dersc(1)
4484         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4485         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4486     1   continue
4487       enddo
4488       return
4489       end
4490 C---------------------------------------------------------------------------
4491       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4492       implicit real*8 (a-h,o-z)
4493       include 'DIMENSIONS'
4494       include 'COMMON.GEO'
4495       include 'COMMON.LOCAL'
4496       include 'COMMON.IOUNITS'
4497       common /sccalc/ time11,time12,time112,theti,it,nlobit
4498       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4499       double precision contr(maxlob,-1:1)
4500       logical mixed
4501 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4502         escloc_i=0.0D0
4503         do j=1,3
4504           dersc(j)=0.0D0
4505           if (mixed) ddersc(j)=0.0d0
4506         enddo
4507         x3=x(3)
4508
4509 C Because of periodicity of the dependence of the SC energy in omega we have
4510 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4511 C To avoid underflows, first compute & store the exponents.
4512
4513         do iii=-1,1
4514
4515           x(3)=x3+iii*dwapi
4516
4517           do j=1,nlobit
4518             do k=1,3
4519               z(k)=x(k)-censc(k,j,it)
4520             enddo
4521             do k=1,3
4522               Axk=0.0D0
4523               do l=1,3
4524                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4525               enddo
4526               Ax(k,j,iii)=Axk
4527             enddo
4528             expfac=0.0D0
4529             do k=1,3
4530               expfac=expfac+Ax(k,j,iii)*z(k)
4531             enddo
4532             contr(j,iii)=expfac
4533           enddo ! j
4534
4535         enddo ! iii
4536
4537         x(3)=x3
4538 C As in the case of ebend, we want to avoid underflows in exponentiation and
4539 C subsequent NaNs and INFs in energy calculation.
4540 C Find the largest exponent
4541         emin=contr(1,-1)
4542         do iii=-1,1
4543           do j=1,nlobit
4544             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4545           enddo
4546         enddo
4547         emin=0.5D0*emin
4548 cd      print *,'it=',it,' emin=',emin
4549
4550 C Compute the contribution to SC energy and derivatives
4551         do iii=-1,1
4552
4553           do j=1,nlobit
4554             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4555 cd          print *,'j=',j,' expfac=',expfac
4556             escloc_i=escloc_i+expfac
4557             do k=1,3
4558               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4559             enddo
4560             if (mixed) then
4561               do k=1,3,2
4562                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4563      &            +gaussc(k,2,j,it))*expfac
4564               enddo
4565             endif
4566           enddo
4567
4568         enddo ! iii
4569
4570         dersc(1)=dersc(1)/cos(theti)**2
4571         ddersc(1)=ddersc(1)/cos(theti)**2
4572         ddersc(3)=ddersc(3)
4573
4574         escloci=-(dlog(escloc_i)-emin)
4575         do j=1,3
4576           dersc(j)=dersc(j)/escloc_i
4577         enddo
4578         if (mixed) then
4579           do j=1,3,2
4580             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4581           enddo
4582         endif
4583       return
4584       end
4585 C------------------------------------------------------------------------------
4586       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4587       implicit real*8 (a-h,o-z)
4588       include 'DIMENSIONS'
4589       include 'COMMON.GEO'
4590       include 'COMMON.LOCAL'
4591       include 'COMMON.IOUNITS'
4592       common /sccalc/ time11,time12,time112,theti,it,nlobit
4593       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4594       double precision contr(maxlob)
4595       logical mixed
4596
4597       escloc_i=0.0D0
4598
4599       do j=1,3
4600         dersc(j)=0.0D0
4601       enddo
4602
4603       do j=1,nlobit
4604         do k=1,2
4605           z(k)=x(k)-censc(k,j,it)
4606         enddo
4607         z(3)=dwapi
4608         do k=1,3
4609           Axk=0.0D0
4610           do l=1,3
4611             Axk=Axk+gaussc(l,k,j,it)*z(l)
4612           enddo
4613           Ax(k,j)=Axk
4614         enddo
4615         expfac=0.0D0
4616         do k=1,3
4617           expfac=expfac+Ax(k,j)*z(k)
4618         enddo
4619         contr(j)=expfac
4620       enddo ! j
4621
4622 C As in the case of ebend, we want to avoid underflows in exponentiation and
4623 C subsequent NaNs and INFs in energy calculation.
4624 C Find the largest exponent
4625       emin=contr(1)
4626       do j=1,nlobit
4627         if (emin.gt.contr(j)) emin=contr(j)
4628       enddo
4629       emin=0.5D0*emin
4630
4631 C Compute the contribution to SC energy and derivatives
4632
4633       dersc12=0.0d0
4634       do j=1,nlobit
4635         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4636         escloc_i=escloc_i+expfac
4637         do k=1,2
4638           dersc(k)=dersc(k)+Ax(k,j)*expfac
4639         enddo
4640         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4641      &            +gaussc(1,2,j,it))*expfac
4642         dersc(3)=0.0d0
4643       enddo
4644
4645       dersc(1)=dersc(1)/cos(theti)**2
4646       dersc12=dersc12/cos(theti)**2
4647       escloci=-(dlog(escloc_i)-emin)
4648       do j=1,2
4649         dersc(j)=dersc(j)/escloc_i
4650       enddo
4651       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4652       return
4653       end
4654 #else
4655 c----------------------------------------------------------------------------------
4656       subroutine esc(escloc)
4657 C Calculate the local energy of a side chain and its derivatives in the
4658 C corresponding virtual-bond valence angles THETA and the spherical angles
4659 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4660 C added by Urszula Kozlowska. 07/11/2007
4661 C
4662       implicit real*8 (a-h,o-z)
4663       include 'DIMENSIONS'
4664       include 'sizesclu.dat'
4665       include 'COMMON.GEO'
4666       include 'COMMON.LOCAL'
4667       include 'COMMON.VAR'
4668       include 'COMMON.SCROT'
4669       include 'COMMON.INTERACT'
4670       include 'COMMON.DERIV'
4671       include 'COMMON.CHAIN'
4672       include 'COMMON.IOUNITS'
4673       include 'COMMON.NAMES'
4674       include 'COMMON.FFIELD'
4675       include 'COMMON.CONTROL'
4676       include 'COMMON.VECTORS'
4677       double precision x_prime(3),y_prime(3),z_prime(3)
4678      &    , sumene,dsc_i,dp2_i,x(65),
4679      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4680      &    de_dxx,de_dyy,de_dzz,de_dt
4681       double precision s1_t,s1_6_t,s2_t,s2_6_t
4682       double precision
4683      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4684      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4685      & dt_dCi(3),dt_dCi1(3)
4686       common /sccalc/ time11,time12,time112,theti,it,nlobit
4687       delta=0.02d0*pi
4688       escloc=0.0D0
4689       do i=loc_start,loc_end
4690         if (itype(i).eq.ntyp1) cycle
4691         costtab(i+1) =dcos(theta(i+1))
4692         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4693         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4694         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4695         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4696         cosfac=dsqrt(cosfac2)
4697         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4698         sinfac=dsqrt(sinfac2)
4699         it=iabs(itype(i))
4700         if (it.eq.10) goto 1
4701 c
4702 C  Compute the axes of tghe local cartesian coordinates system; store in
4703 c   x_prime, y_prime and z_prime
4704 c
4705         do j=1,3
4706           x_prime(j) = 0.00
4707           y_prime(j) = 0.00
4708           z_prime(j) = 0.00
4709         enddo
4710 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4711 C     &   dc_norm(3,i+nres)
4712         do j = 1,3
4713           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4714           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4715         enddo
4716         do j = 1,3
4717           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4718         enddo
4719 c       write (2,*) "i",i
4720 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4721 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4722 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4723 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4724 c      & " xy",scalar(x_prime(1),y_prime(1)),
4725 c      & " xz",scalar(x_prime(1),z_prime(1)),
4726 c      & " yy",scalar(y_prime(1),y_prime(1)),
4727 c      & " yz",scalar(y_prime(1),z_prime(1)),
4728 c      & " zz",scalar(z_prime(1),z_prime(1))
4729 c
4730 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4731 C to local coordinate system. Store in xx, yy, zz.
4732 c
4733         xx=0.0d0
4734         yy=0.0d0
4735         zz=0.0d0
4736         do j = 1,3
4737           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4738           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4739           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4740         enddo
4741
4742         xxtab(i)=xx
4743         yytab(i)=yy
4744         zztab(i)=zz
4745 C
4746 C Compute the energy of the ith side cbain
4747 C
4748 c        write (2,*) "xx",xx," yy",yy," zz",zz
4749         it=iabs(itype(i))
4750         do j = 1,65
4751           x(j) = sc_parmin(j,it)
4752         enddo
4753 #ifdef CHECK_COORD
4754 Cc diagnostics - remove later
4755         xx1 = dcos(alph(2))
4756         yy1 = dsin(alph(2))*dcos(omeg(2))
4757 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4758         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4759         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4760      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4761      &    xx1,yy1,zz1
4762 C,"  --- ", xx_w,yy_w,zz_w
4763 c end diagnostics
4764 #endif
4765         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4766      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4767      &   + x(10)*yy*zz
4768         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4769      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4770      & + x(20)*yy*zz
4771         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4772      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4773      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4774      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4775      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4776      &  +x(40)*xx*yy*zz
4777         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4778      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4779      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4780      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4781      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4782      &  +x(60)*xx*yy*zz
4783         dsc_i   = 0.743d0+x(61)
4784         dp2_i   = 1.9d0+x(62)
4785         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4786      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4787         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4788      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4789         s1=(1+x(63))/(0.1d0 + dscp1)
4790         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4791         s2=(1+x(65))/(0.1d0 + dscp2)
4792         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4793         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4794      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4795 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4796 c     &   sumene4,
4797 c     &   dscp1,dscp2,sumene
4798 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4799         escloc = escloc + sumene
4800 c        write (2,*) "escloc",escloc
4801         if (.not. calc_grad) goto 1
4802 #ifdef DEBUG
4803 C
4804 C This section to check the numerical derivatives of the energy of ith side
4805 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4806 C #define DEBUG in the code to turn it on.
4807 C
4808         write (2,*) "sumene               =",sumene
4809         aincr=1.0d-7
4810         xxsave=xx
4811         xx=xx+aincr
4812         write (2,*) xx,yy,zz
4813         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4814         de_dxx_num=(sumenep-sumene)/aincr
4815         xx=xxsave
4816         write (2,*) "xx+ sumene from enesc=",sumenep
4817         yysave=yy
4818         yy=yy+aincr
4819         write (2,*) xx,yy,zz
4820         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4821         de_dyy_num=(sumenep-sumene)/aincr
4822         yy=yysave
4823         write (2,*) "yy+ sumene from enesc=",sumenep
4824         zzsave=zz
4825         zz=zz+aincr
4826         write (2,*) xx,yy,zz
4827         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4828         de_dzz_num=(sumenep-sumene)/aincr
4829         zz=zzsave
4830         write (2,*) "zz+ sumene from enesc=",sumenep
4831         costsave=cost2tab(i+1)
4832         sintsave=sint2tab(i+1)
4833         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4834         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4835         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4836         de_dt_num=(sumenep-sumene)/aincr
4837         write (2,*) " t+ sumene from enesc=",sumenep
4838         cost2tab(i+1)=costsave
4839         sint2tab(i+1)=sintsave
4840 C End of diagnostics section.
4841 #endif
4842 C
4843 C Compute the gradient of esc
4844 C
4845         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4846         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4847         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4848         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4849         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4850         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4851         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4852         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4853         pom1=(sumene3*sint2tab(i+1)+sumene1)
4854      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4855         pom2=(sumene4*cost2tab(i+1)+sumene2)
4856      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4857         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4858         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4859      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4860      &  +x(40)*yy*zz
4861         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4862         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4863      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4864      &  +x(60)*yy*zz
4865         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4866      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4867      &        +(pom1+pom2)*pom_dx
4868 #ifdef DEBUG
4869         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4870 #endif
4871 C
4872         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4873         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4874      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4875      &  +x(40)*xx*zz
4876         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4877         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4878      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4879      &  +x(59)*zz**2 +x(60)*xx*zz
4880         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4881      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4882      &        +(pom1-pom2)*pom_dy
4883 #ifdef DEBUG
4884         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4885 #endif
4886 C
4887         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4888      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4889      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4890      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4891      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4892      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4893      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4894      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4895 #ifdef DEBUG
4896         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4897 #endif
4898 C
4899         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4900      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4901      &  +pom1*pom_dt1+pom2*pom_dt2
4902 #ifdef DEBUG
4903         write(2,*), "de_dt = ", de_dt,de_dt_num
4904 #endif
4905 c
4906 C
4907        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4908        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4909        cosfac2xx=cosfac2*xx
4910        sinfac2yy=sinfac2*yy
4911        do k = 1,3
4912          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4913      &      vbld_inv(i+1)
4914          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4915      &      vbld_inv(i)
4916          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4917          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4918 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4919 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4920 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4921 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4922          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4923          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4924          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4925          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4926          dZZ_Ci1(k)=0.0d0
4927          dZZ_Ci(k)=0.0d0
4928          do j=1,3
4929            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4930      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4931            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4932      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4933          enddo
4934
4935          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4936          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4937          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4938 c
4939          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4940          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4941        enddo
4942
4943        do k=1,3
4944          dXX_Ctab(k,i)=dXX_Ci(k)
4945          dXX_C1tab(k,i)=dXX_Ci1(k)
4946          dYY_Ctab(k,i)=dYY_Ci(k)
4947          dYY_C1tab(k,i)=dYY_Ci1(k)
4948          dZZ_Ctab(k,i)=dZZ_Ci(k)
4949          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4950          dXX_XYZtab(k,i)=dXX_XYZ(k)
4951          dYY_XYZtab(k,i)=dYY_XYZ(k)
4952          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4953        enddo
4954
4955        do k = 1,3
4956 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4957 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4958 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4959 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4960 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4961 c     &    dt_dci(k)
4962 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4963 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4964          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4965      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4966          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4967      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4968          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4969      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4970        enddo
4971 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4972 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4973
4974 C to check gradient call subroutine check_grad
4975
4976     1 continue
4977       enddo
4978       return
4979       end
4980 #endif
4981 c------------------------------------------------------------------------------
4982       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4983 C
4984 C This procedure calculates two-body contact function g(rij) and its derivative:
4985 C
4986 C           eps0ij                                     !       x < -1
4987 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4988 C            0                                         !       x > 1
4989 C
4990 C where x=(rij-r0ij)/delta
4991 C
4992 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4993 C
4994       implicit none
4995       double precision rij,r0ij,eps0ij,fcont,fprimcont
4996       double precision x,x2,x4,delta
4997 c     delta=0.02D0*r0ij
4998 c      delta=0.2D0*r0ij
4999       x=(rij-r0ij)/delta
5000       if (x.lt.-1.0D0) then
5001         fcont=eps0ij
5002         fprimcont=0.0D0
5003       else if (x.le.1.0D0) then
5004         x2=x*x
5005         x4=x2*x2
5006         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5007         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5008       else
5009         fcont=0.0D0
5010         fprimcont=0.0D0
5011       endif
5012       return
5013       end
5014 c------------------------------------------------------------------------------
5015       subroutine splinthet(theti,delta,ss,ssder)
5016       implicit real*8 (a-h,o-z)
5017       include 'DIMENSIONS'
5018       include 'sizesclu.dat'
5019       include 'COMMON.VAR'
5020       include 'COMMON.GEO'
5021       thetup=pi-delta
5022       thetlow=delta
5023       if (theti.gt.pipol) then
5024         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5025       else
5026         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5027         ssder=-ssder
5028       endif
5029       return
5030       end
5031 c------------------------------------------------------------------------------
5032       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5033       implicit none
5034       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5035       double precision ksi,ksi2,ksi3,a1,a2,a3
5036       a1=fprim0*delta/(f1-f0)
5037       a2=3.0d0-2.0d0*a1
5038       a3=a1-2.0d0
5039       ksi=(x-x0)/delta
5040       ksi2=ksi*ksi
5041       ksi3=ksi2*ksi
5042       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5043       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5044       return
5045       end
5046 c------------------------------------------------------------------------------
5047       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5048       implicit none
5049       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5050       double precision ksi,ksi2,ksi3,a1,a2,a3
5051       ksi=(x-x0)/delta
5052       ksi2=ksi*ksi
5053       ksi3=ksi2*ksi
5054       a1=fprim0x*delta
5055       a2=3*(f1x-f0x)-2*fprim0x*delta
5056       a3=fprim0x*delta-2*(f1x-f0x)
5057       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5058       return
5059       end
5060 C-----------------------------------------------------------------------------
5061 #ifdef CRYST_TOR
5062 C-----------------------------------------------------------------------------
5063       subroutine etor(etors,edihcnstr,fact)
5064       implicit real*8 (a-h,o-z)
5065       include 'DIMENSIONS'
5066       include 'sizesclu.dat'
5067       include 'COMMON.VAR'
5068       include 'COMMON.GEO'
5069       include 'COMMON.LOCAL'
5070       include 'COMMON.TORSION'
5071       include 'COMMON.INTERACT'
5072       include 'COMMON.DERIV'
5073       include 'COMMON.CHAIN'
5074       include 'COMMON.NAMES'
5075       include 'COMMON.IOUNITS'
5076       include 'COMMON.FFIELD'
5077       include 'COMMON.TORCNSTR'
5078       logical lprn
5079 C Set lprn=.true. for debugging
5080       lprn=.false.
5081 c      lprn=.true.
5082       etors=0.0D0
5083       do i=iphi_start,iphi_end
5084         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5085      &      .or. itype(i).eq.ntyp1) cycle
5086         itori=itortyp(itype(i-2))
5087         itori1=itortyp(itype(i-1))
5088         phii=phi(i)
5089         gloci=0.0D0
5090 C Proline-Proline pair is a special case...
5091         if (itori.eq.3 .and. itori1.eq.3) then
5092           if (phii.gt.-dwapi3) then
5093             cosphi=dcos(3*phii)
5094             fac=1.0D0/(1.0D0-cosphi)
5095             etorsi=v1(1,3,3)*fac
5096             etorsi=etorsi+etorsi
5097             etors=etors+etorsi-v1(1,3,3)
5098             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5099           endif
5100           do j=1,3
5101             v1ij=v1(j+1,itori,itori1)
5102             v2ij=v2(j+1,itori,itori1)
5103             cosphi=dcos(j*phii)
5104             sinphi=dsin(j*phii)
5105             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5106             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5107           enddo
5108         else
5109           do j=1,nterm_old
5110             v1ij=v1(j,itori,itori1)
5111             v2ij=v2(j,itori,itori1)
5112             cosphi=dcos(j*phii)
5113             sinphi=dsin(j*phii)
5114             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5115             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5116           enddo
5117         endif
5118         if (lprn)
5119      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5120      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5121      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5122         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5123 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5124       enddo
5125 ! 6/20/98 - dihedral angle constraints
5126       edihcnstr=0.0d0
5127       do i=1,ndih_constr
5128         itori=idih_constr(i)
5129         phii=phi(itori)
5130         difi=phii-phi0(i)
5131         if (difi.gt.drange(i)) then
5132           difi=difi-drange(i)
5133           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5134           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5135         else if (difi.lt.-drange(i)) then
5136           difi=difi+drange(i)
5137           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5138           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5139         endif
5140 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5141 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5142       enddo
5143 !      write (iout,*) 'edihcnstr',edihcnstr
5144       return
5145       end
5146 c------------------------------------------------------------------------------
5147 #else
5148       subroutine etor(etors,edihcnstr,fact)
5149       implicit real*8 (a-h,o-z)
5150       include 'DIMENSIONS'
5151       include 'sizesclu.dat'
5152       include 'COMMON.VAR'
5153       include 'COMMON.GEO'
5154       include 'COMMON.LOCAL'
5155       include 'COMMON.TORSION'
5156       include 'COMMON.INTERACT'
5157       include 'COMMON.DERIV'
5158       include 'COMMON.CHAIN'
5159       include 'COMMON.NAMES'
5160       include 'COMMON.IOUNITS'
5161       include 'COMMON.FFIELD'
5162       include 'COMMON.TORCNSTR'
5163       logical lprn
5164 C Set lprn=.true. for debugging
5165       lprn=.false.
5166 c      lprn=.true.
5167       etors=0.0D0
5168       do i=iphi_start,iphi_end
5169         if (i.le.2) cycle
5170         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5171      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5172         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5173          if (iabs(itype(i)).eq.20) then
5174          iblock=2
5175          else
5176          iblock=1
5177          endif
5178         itori=itortyp(itype(i-2))
5179         itori1=itortyp(itype(i-1))
5180         phii=phi(i)
5181         gloci=0.0D0
5182 C Regular cosine and sine terms
5183         do j=1,nterm(itori,itori1,iblock)
5184           v1ij=v1(j,itori,itori1,iblock)
5185           v2ij=v2(j,itori,itori1,iblock)
5186           cosphi=dcos(j*phii)
5187           sinphi=dsin(j*phii)
5188           etors=etors+v1ij*cosphi+v2ij*sinphi
5189           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5190         enddo
5191 C Lorentz terms
5192 C                         v1
5193 C  E = SUM ----------------------------------- - v1
5194 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5195 C
5196         cosphi=dcos(0.5d0*phii)
5197         sinphi=dsin(0.5d0*phii)
5198         do j=1,nlor(itori,itori1,iblock)
5199           vl1ij=vlor1(j,itori,itori1)
5200           vl2ij=vlor2(j,itori,itori1)
5201           vl3ij=vlor3(j,itori,itori1)
5202           pom=vl2ij*cosphi+vl3ij*sinphi
5203           pom1=1.0d0/(pom*pom+1.0d0)
5204           etors=etors+vl1ij*pom1
5205           pom=-pom*pom1*pom1
5206           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5207         enddo
5208 C Subtract the constant term
5209         etors=etors-v0(itori,itori1,iblock)
5210         if (lprn)
5211      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5212      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5213      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5214         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5215 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5216  1215   continue
5217       enddo
5218 ! 6/20/98 - dihedral angle constraints
5219       edihcnstr=0.0d0
5220       do i=1,ndih_constr
5221         itori=idih_constr(i)
5222         phii=phi(itori)
5223         difi=pinorm(phii-phi0(i))
5224         edihi=0.0d0
5225         if (difi.gt.drange(i)) then
5226           difi=difi-drange(i)
5227           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5228           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5229           edihi=0.25d0*ftors(i)*difi**4
5230         else if (difi.lt.-drange(i)) then
5231           difi=difi+drange(i)
5232           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5233           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5234           edihi=0.25d0*ftors(i)*difi**4
5235         else
5236           difi=0.0d0
5237         endif
5238 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5239 c     &    drange(i),edihi
5240 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5241 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5242       enddo
5243 !      write (iout,*) 'edihcnstr',edihcnstr
5244       return
5245       end
5246 c----------------------------------------------------------------------------
5247       subroutine etor_d(etors_d,fact2)
5248 C 6/23/01 Compute double torsional energy
5249       implicit real*8 (a-h,o-z)
5250       include 'DIMENSIONS'
5251       include 'sizesclu.dat'
5252       include 'COMMON.VAR'
5253       include 'COMMON.GEO'
5254       include 'COMMON.LOCAL'
5255       include 'COMMON.TORSION'
5256       include 'COMMON.INTERACT'
5257       include 'COMMON.DERIV'
5258       include 'COMMON.CHAIN'
5259       include 'COMMON.NAMES'
5260       include 'COMMON.IOUNITS'
5261       include 'COMMON.FFIELD'
5262       include 'COMMON.TORCNSTR'
5263       logical lprn
5264 C Set lprn=.true. for debugging
5265       lprn=.false.
5266 c     lprn=.true.
5267       etors_d=0.0D0
5268       do i=iphi_start,iphi_end-1
5269         if (i.le.3) cycle
5270          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5271      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5272      &  (itype(i+1).eq.ntyp1)) cycle
5273         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5274      &     goto 1215
5275         itori=itortyp(itype(i-2))
5276         itori1=itortyp(itype(i-1))
5277         itori2=itortyp(itype(i))
5278         phii=phi(i)
5279         phii1=phi(i+1)
5280         gloci1=0.0D0
5281         gloci2=0.0D0
5282         iblock=1
5283         if (iabs(itype(i+1)).eq.20) iblock=2
5284 C Regular cosine and sine terms
5285        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5286           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5287           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5288           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5289           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5290           cosphi1=dcos(j*phii)
5291           sinphi1=dsin(j*phii)
5292           cosphi2=dcos(j*phii1)
5293           sinphi2=dsin(j*phii1)
5294           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5295      &     v2cij*cosphi2+v2sij*sinphi2
5296           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5297           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5298         enddo
5299         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5300           do l=1,k-1
5301             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5302             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5303             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5304             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5305             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5306             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5307             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5308             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5309             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5310      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5311             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5312      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5313             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5314      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5315           enddo
5316         enddo
5317         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5318         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5319  1215   continue
5320       enddo
5321       return
5322       end
5323 #endif
5324 c------------------------------------------------------------------------------
5325       subroutine eback_sc_corr(esccor)
5326 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5327 c        conformational states; temporarily implemented as differences
5328 c        between UNRES torsional potentials (dependent on three types of
5329 c        residues) and the torsional potentials dependent on all 20 types
5330 c        of residues computed from AM1 energy surfaces of terminally-blocked
5331 c        amino-acid residues.
5332       implicit real*8 (a-h,o-z)
5333       include 'DIMENSIONS'
5334       include 'sizesclu.dat'
5335       include 'COMMON.VAR'
5336       include 'COMMON.GEO'
5337       include 'COMMON.LOCAL'
5338       include 'COMMON.TORSION'
5339       include 'COMMON.SCCOR'
5340       include 'COMMON.INTERACT'
5341       include 'COMMON.DERIV'
5342       include 'COMMON.CHAIN'
5343       include 'COMMON.NAMES'
5344       include 'COMMON.IOUNITS'
5345       include 'COMMON.FFIELD'
5346       include 'COMMON.CONTROL'
5347       logical lprn
5348 C Set lprn=.true. for debugging
5349       lprn=.false.
5350 c      lprn=.true.
5351 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5352       esccor=0.0D0
5353       do i=itau_start,itau_end
5354         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5355         esccor_ii=0.0D0
5356         isccori=isccortyp(itype(i-2))
5357         isccori1=isccortyp(itype(i-1))
5358         phii=phi(i)
5359         do intertyp=1,3 !intertyp
5360 cc Added 09 May 2012 (Adasko)
5361 cc  Intertyp means interaction type of backbone mainchain correlation:
5362 c   1 = SC...Ca...Ca...Ca
5363 c   2 = Ca...Ca...Ca...SC
5364 c   3 = SC...Ca...Ca...SCi
5365         gloci=0.0D0
5366         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5367      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5368      &      (itype(i-1).eq.ntyp1)))
5369      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5370      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5371      &     .or.(itype(i).eq.ntyp1)))
5372      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5373      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5374      &      (itype(i-3).eq.ntyp1)))) cycle
5375         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5376         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5377      & cycle
5378        do j=1,nterm_sccor(isccori,isccori1)
5379           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5380           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5381           cosphi=dcos(j*tauangle(intertyp,i))
5382           sinphi=dsin(j*tauangle(intertyp,i))
5383            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5384 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5385          enddo
5386 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5387 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5388         if (lprn)
5389      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5390      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5391      &  (v1sccor(j,1,itori,itori1),j=1,6),
5392      &  (v2sccor(j,1,itori,itori1),j=1,6)
5393         gsccor_loc(i-3)=gloci
5394        enddo !intertyp
5395       enddo
5396       return
5397       end
5398 c------------------------------------------------------------------------------
5399       subroutine multibody(ecorr)
5400 C This subroutine calculates multi-body contributions to energy following
5401 C the idea of Skolnick et al. If side chains I and J make a contact and
5402 C at the same time side chains I+1 and J+1 make a contact, an extra
5403 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5404       implicit real*8 (a-h,o-z)
5405       include 'DIMENSIONS'
5406       include 'COMMON.IOUNITS'
5407       include 'COMMON.DERIV'
5408       include 'COMMON.INTERACT'
5409       include 'COMMON.CONTACTS'
5410       double precision gx(3),gx1(3)
5411       logical lprn
5412
5413 C Set lprn=.true. for debugging
5414       lprn=.false.
5415
5416       if (lprn) then
5417         write (iout,'(a)') 'Contact function values:'
5418         do i=nnt,nct-2
5419           write (iout,'(i2,20(1x,i2,f10.5))')
5420      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5421         enddo
5422       endif
5423       ecorr=0.0D0
5424       do i=nnt,nct
5425         do j=1,3
5426           gradcorr(j,i)=0.0D0
5427           gradxorr(j,i)=0.0D0
5428         enddo
5429       enddo
5430       do i=nnt,nct-2
5431
5432         DO ISHIFT = 3,4
5433
5434         i1=i+ishift
5435         num_conti=num_cont(i)
5436         num_conti1=num_cont(i1)
5437         do jj=1,num_conti
5438           j=jcont(jj,i)
5439           do kk=1,num_conti1
5440             j1=jcont(kk,i1)
5441             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5442 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5443 cd   &                   ' ishift=',ishift
5444 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5445 C The system gains extra energy.
5446               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5447             endif   ! j1==j+-ishift
5448           enddo     ! kk
5449         enddo       ! jj
5450
5451         ENDDO ! ISHIFT
5452
5453       enddo         ! i
5454       return
5455       end
5456 c------------------------------------------------------------------------------
5457       double precision function esccorr(i,j,k,l,jj,kk)
5458       implicit real*8 (a-h,o-z)
5459       include 'DIMENSIONS'
5460       include 'COMMON.IOUNITS'
5461       include 'COMMON.DERIV'
5462       include 'COMMON.INTERACT'
5463       include 'COMMON.CONTACTS'
5464       double precision gx(3),gx1(3)
5465       logical lprn
5466       lprn=.false.
5467       eij=facont(jj,i)
5468       ekl=facont(kk,k)
5469 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5470 C Calculate the multi-body contribution to energy.
5471 C Calculate multi-body contributions to the gradient.
5472 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5473 cd   & k,l,(gacont(m,kk,k),m=1,3)
5474       do m=1,3
5475         gx(m) =ekl*gacont(m,jj,i)
5476         gx1(m)=eij*gacont(m,kk,k)
5477         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5478         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5479         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5480         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5481       enddo
5482       do m=i,j-1
5483         do ll=1,3
5484           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5485         enddo
5486       enddo
5487       do m=k,l-1
5488         do ll=1,3
5489           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5490         enddo
5491       enddo
5492       esccorr=-eij*ekl
5493       return
5494       end
5495 c------------------------------------------------------------------------------
5496 #ifdef MPL
5497       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5498       implicit real*8 (a-h,o-z)
5499       include 'DIMENSIONS'
5500       integer dimen1,dimen2,atom,indx
5501       double precision buffer(dimen1,dimen2)
5502       double precision zapas
5503       common /contacts_hb/ zapas(3,20,maxres,7),
5504      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5505      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5506       num_kont=num_cont_hb(atom)
5507       do i=1,num_kont
5508         do k=1,7
5509           do j=1,3
5510             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5511           enddo ! j
5512         enddo ! k
5513         buffer(i,indx+22)=facont_hb(i,atom)
5514         buffer(i,indx+23)=ees0p(i,atom)
5515         buffer(i,indx+24)=ees0m(i,atom)
5516         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5517       enddo ! i
5518       buffer(1,indx+26)=dfloat(num_kont)
5519       return
5520       end
5521 c------------------------------------------------------------------------------
5522       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5523       implicit real*8 (a-h,o-z)
5524       include 'DIMENSIONS'
5525       integer dimen1,dimen2,atom,indx
5526       double precision buffer(dimen1,dimen2)
5527       double precision zapas
5528       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5529      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5530      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5531       num_kont=buffer(1,indx+26)
5532       num_kont_old=num_cont_hb(atom)
5533       num_cont_hb(atom)=num_kont+num_kont_old
5534       do i=1,num_kont
5535         ii=i+num_kont_old
5536         do k=1,7
5537           do j=1,3
5538             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5539           enddo ! j
5540         enddo ! k
5541         facont_hb(ii,atom)=buffer(i,indx+22)
5542         ees0p(ii,atom)=buffer(i,indx+23)
5543         ees0m(ii,atom)=buffer(i,indx+24)
5544         jcont_hb(ii,atom)=buffer(i,indx+25)
5545       enddo ! i
5546       return
5547       end
5548 c------------------------------------------------------------------------------
5549 #endif
5550       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5551 C This subroutine calculates multi-body contributions to hydrogen-bonding
5552       implicit real*8 (a-h,o-z)
5553       include 'DIMENSIONS'
5554       include 'sizesclu.dat'
5555       include 'COMMON.IOUNITS'
5556 #ifdef MPL
5557       include 'COMMON.INFO'
5558 #endif
5559       include 'COMMON.FFIELD'
5560       include 'COMMON.DERIV'
5561       include 'COMMON.INTERACT'
5562       include 'COMMON.CONTACTS'
5563 #ifdef MPL
5564       parameter (max_cont=maxconts)
5565       parameter (max_dim=2*(8*3+2))
5566       parameter (msglen1=max_cont*max_dim*4)
5567       parameter (msglen2=2*msglen1)
5568       integer source,CorrelType,CorrelID,Error
5569       double precision buffer(max_cont,max_dim)
5570 #endif
5571       double precision gx(3),gx1(3)
5572       logical lprn,ldone
5573
5574 C Set lprn=.true. for debugging
5575       lprn=.false.
5576 #ifdef MPL
5577       n_corr=0
5578       n_corr1=0
5579       if (fgProcs.le.1) goto 30
5580       if (lprn) then
5581         write (iout,'(a)') 'Contact function values:'
5582         do i=nnt,nct-2
5583           write (iout,'(2i3,50(1x,i2,f5.2))')
5584      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5585      &    j=1,num_cont_hb(i))
5586         enddo
5587       endif
5588 C Caution! Following code assumes that electrostatic interactions concerning
5589 C a given atom are split among at most two processors!
5590       CorrelType=477
5591       CorrelID=MyID+1
5592       ldone=.false.
5593       do i=1,max_cont
5594         do j=1,max_dim
5595           buffer(i,j)=0.0D0
5596         enddo
5597       enddo
5598       mm=mod(MyRank,2)
5599 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5600       if (mm) 20,20,10
5601    10 continue
5602 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5603       if (MyRank.gt.0) then
5604 C Send correlation contributions to the preceding processor
5605         msglen=msglen1
5606         nn=num_cont_hb(iatel_s)
5607         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5608 cd      write (iout,*) 'The BUFFER array:'
5609 cd      do i=1,nn
5610 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5611 cd      enddo
5612         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5613           msglen=msglen2
5614             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5615 C Clear the contacts of the atom passed to the neighboring processor
5616         nn=num_cont_hb(iatel_s+1)
5617 cd      do i=1,nn
5618 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5619 cd      enddo
5620             num_cont_hb(iatel_s)=0
5621         endif
5622 cd      write (iout,*) 'Processor ',MyID,MyRank,
5623 cd   & ' is sending correlation contribution to processor',MyID-1,
5624 cd   & ' msglen=',msglen
5625 cd      write (*,*) 'Processor ',MyID,MyRank,
5626 cd   & ' is sending correlation contribution to processor',MyID-1,
5627 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5628         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5629 cd      write (iout,*) 'Processor ',MyID,
5630 cd   & ' has sent correlation contribution to processor',MyID-1,
5631 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5632 cd      write (*,*) 'Processor ',MyID,
5633 cd   & ' has sent correlation contribution to processor',MyID-1,
5634 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5635         msglen=msglen1
5636       endif ! (MyRank.gt.0)
5637       if (ldone) goto 30
5638       ldone=.true.
5639    20 continue
5640 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5641       if (MyRank.lt.fgProcs-1) then
5642 C Receive correlation contributions from the next processor
5643         msglen=msglen1
5644         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5645 cd      write (iout,*) 'Processor',MyID,
5646 cd   & ' is receiving correlation contribution from processor',MyID+1,
5647 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5648 cd      write (*,*) 'Processor',MyID,
5649 cd   & ' is receiving correlation contribution from processor',MyID+1,
5650 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5651         nbytes=-1
5652         do while (nbytes.le.0)
5653           call mp_probe(MyID+1,CorrelType,nbytes)
5654         enddo
5655 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5656         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5657 cd      write (iout,*) 'Processor',MyID,
5658 cd   & ' has received correlation contribution from processor',MyID+1,
5659 cd   & ' msglen=',msglen,' nbytes=',nbytes
5660 cd      write (iout,*) 'The received BUFFER array:'
5661 cd      do i=1,max_cont
5662 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5663 cd      enddo
5664         if (msglen.eq.msglen1) then
5665           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5666         else if (msglen.eq.msglen2)  then
5667           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5668           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5669         else
5670           write (iout,*)
5671      & 'ERROR!!!! message length changed while processing correlations.'
5672           write (*,*)
5673      & 'ERROR!!!! message length changed while processing correlations.'
5674           call mp_stopall(Error)
5675         endif ! msglen.eq.msglen1
5676       endif ! MyRank.lt.fgProcs-1
5677       if (ldone) goto 30
5678       ldone=.true.
5679       goto 10
5680    30 continue
5681 #endif
5682       if (lprn) then
5683         write (iout,'(a)') 'Contact function values:'
5684         do i=nnt,nct-2
5685           write (iout,'(2i3,50(1x,i2,f5.2))')
5686      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5687      &    j=1,num_cont_hb(i))
5688         enddo
5689       endif
5690       ecorr=0.0D0
5691 C Remove the loop below after debugging !!!
5692       do i=nnt,nct
5693         do j=1,3
5694           gradcorr(j,i)=0.0D0
5695           gradxorr(j,i)=0.0D0
5696         enddo
5697       enddo
5698 C Calculate the local-electrostatic correlation terms
5699       do i=iatel_s,iatel_e+1
5700         i1=i+1
5701         num_conti=num_cont_hb(i)
5702         num_conti1=num_cont_hb(i+1)
5703         do jj=1,num_conti
5704           j=jcont_hb(jj,i)
5705           do kk=1,num_conti1
5706             j1=jcont_hb(kk,i1)
5707 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5708 c     &         ' jj=',jj,' kk=',kk
5709             if (j1.eq.j+1 .or. j1.eq.j-1) then
5710 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5711 C The system gains extra energy.
5712               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5713               n_corr=n_corr+1
5714             else if (j1.eq.j) then
5715 C Contacts I-J and I-(J+1) occur simultaneously.
5716 C The system loses extra energy.
5717 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5718             endif
5719           enddo ! kk
5720           do kk=1,num_conti
5721             j1=jcont_hb(kk,i)
5722 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5723 c    &         ' jj=',jj,' kk=',kk
5724             if (j1.eq.j+1) then
5725 C Contacts I-J and (I+1)-J occur simultaneously.
5726 C The system loses extra energy.
5727 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5728             endif ! j1==j+1
5729           enddo ! kk
5730         enddo ! jj
5731       enddo ! i
5732       return
5733       end
5734 c------------------------------------------------------------------------------
5735       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5736      &  n_corr1)
5737 C This subroutine calculates multi-body contributions to hydrogen-bonding
5738       implicit real*8 (a-h,o-z)
5739       include 'DIMENSIONS'
5740       include 'sizesclu.dat'
5741       include 'COMMON.IOUNITS'
5742 #ifdef MPL
5743       include 'COMMON.INFO'
5744 #endif
5745       include 'COMMON.FFIELD'
5746       include 'COMMON.DERIV'
5747       include 'COMMON.INTERACT'
5748       include 'COMMON.CONTACTS'
5749 #ifdef MPL
5750       parameter (max_cont=maxconts)
5751       parameter (max_dim=2*(8*3+2))
5752       parameter (msglen1=max_cont*max_dim*4)
5753       parameter (msglen2=2*msglen1)
5754       integer source,CorrelType,CorrelID,Error
5755       double precision buffer(max_cont,max_dim)
5756 #endif
5757       double precision gx(3),gx1(3)
5758       logical lprn,ldone
5759
5760 C Set lprn=.true. for debugging
5761       lprn=.false.
5762       eturn6=0.0d0
5763 #ifdef MPL
5764       n_corr=0
5765       n_corr1=0
5766       if (fgProcs.le.1) goto 30
5767       if (lprn) then
5768         write (iout,'(a)') 'Contact function values:'
5769         do i=nnt,nct-2
5770           write (iout,'(2i3,50(1x,i2,f5.2))')
5771      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5772      &    j=1,num_cont_hb(i))
5773         enddo
5774       endif
5775 C Caution! Following code assumes that electrostatic interactions concerning
5776 C a given atom are split among at most two processors!
5777       CorrelType=477
5778       CorrelID=MyID+1
5779       ldone=.false.
5780       do i=1,max_cont
5781         do j=1,max_dim
5782           buffer(i,j)=0.0D0
5783         enddo
5784       enddo
5785       mm=mod(MyRank,2)
5786 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5787       if (mm) 20,20,10
5788    10 continue
5789 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5790       if (MyRank.gt.0) then
5791 C Send correlation contributions to the preceding processor
5792         msglen=msglen1
5793         nn=num_cont_hb(iatel_s)
5794         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5795 cd      write (iout,*) 'The BUFFER array:'
5796 cd      do i=1,nn
5797 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5798 cd      enddo
5799         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5800           msglen=msglen2
5801             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5802 C Clear the contacts of the atom passed to the neighboring processor
5803         nn=num_cont_hb(iatel_s+1)
5804 cd      do i=1,nn
5805 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5806 cd      enddo
5807             num_cont_hb(iatel_s)=0
5808         endif
5809 cd      write (iout,*) 'Processor ',MyID,MyRank,
5810 cd   & ' is sending correlation contribution to processor',MyID-1,
5811 cd   & ' msglen=',msglen
5812 cd      write (*,*) 'Processor ',MyID,MyRank,
5813 cd   & ' is sending correlation contribution to processor',MyID-1,
5814 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5815         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5816 cd      write (iout,*) 'Processor ',MyID,
5817 cd   & ' has sent correlation contribution to processor',MyID-1,
5818 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5819 cd      write (*,*) 'Processor ',MyID,
5820 cd   & ' has sent correlation contribution to processor',MyID-1,
5821 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5822         msglen=msglen1
5823       endif ! (MyRank.gt.0)
5824       if (ldone) goto 30
5825       ldone=.true.
5826    20 continue
5827 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5828       if (MyRank.lt.fgProcs-1) then
5829 C Receive correlation contributions from the next processor
5830         msglen=msglen1
5831         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5832 cd      write (iout,*) 'Processor',MyID,
5833 cd   & ' is receiving correlation contribution from processor',MyID+1,
5834 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5835 cd      write (*,*) 'Processor',MyID,
5836 cd   & ' is receiving correlation contribution from processor',MyID+1,
5837 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5838         nbytes=-1
5839         do while (nbytes.le.0)
5840           call mp_probe(MyID+1,CorrelType,nbytes)
5841         enddo
5842 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5843         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5844 cd      write (iout,*) 'Processor',MyID,
5845 cd   & ' has received correlation contribution from processor',MyID+1,
5846 cd   & ' msglen=',msglen,' nbytes=',nbytes
5847 cd      write (iout,*) 'The received BUFFER array:'
5848 cd      do i=1,max_cont
5849 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5850 cd      enddo
5851         if (msglen.eq.msglen1) then
5852           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5853         else if (msglen.eq.msglen2)  then
5854           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5855           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5856         else
5857           write (iout,*)
5858      & 'ERROR!!!! message length changed while processing correlations.'
5859           write (*,*)
5860      & 'ERROR!!!! message length changed while processing correlations.'
5861           call mp_stopall(Error)
5862         endif ! msglen.eq.msglen1
5863       endif ! MyRank.lt.fgProcs-1
5864       if (ldone) goto 30
5865       ldone=.true.
5866       goto 10
5867    30 continue
5868 #endif
5869       if (lprn) then
5870         write (iout,'(a)') 'Contact function values:'
5871         do i=nnt,nct-2
5872           write (iout,'(2i3,50(1x,i2,f5.2))')
5873      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5874      &    j=1,num_cont_hb(i))
5875         enddo
5876       endif
5877       ecorr=0.0D0
5878       ecorr5=0.0d0
5879       ecorr6=0.0d0
5880 C Remove the loop below after debugging !!!
5881       do i=nnt,nct
5882         do j=1,3
5883           gradcorr(j,i)=0.0D0
5884           gradxorr(j,i)=0.0D0
5885         enddo
5886       enddo
5887 C Calculate the dipole-dipole interaction energies
5888       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5889       do i=iatel_s,iatel_e+1
5890         num_conti=num_cont_hb(i)
5891         do jj=1,num_conti
5892           j=jcont_hb(jj,i)
5893           call dipole(i,j,jj)
5894         enddo
5895       enddo
5896       endif
5897 C Calculate the local-electrostatic correlation terms
5898       do i=iatel_s,iatel_e+1
5899         i1=i+1
5900         num_conti=num_cont_hb(i)
5901         num_conti1=num_cont_hb(i+1)
5902         do jj=1,num_conti
5903           j=jcont_hb(jj,i)
5904           do kk=1,num_conti1
5905             j1=jcont_hb(kk,i1)
5906 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5907 c     &         ' jj=',jj,' kk=',kk
5908             if (j1.eq.j+1 .or. j1.eq.j-1) then
5909 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5910 C The system gains extra energy.
5911               n_corr=n_corr+1
5912               sqd1=dsqrt(d_cont(jj,i))
5913               sqd2=dsqrt(d_cont(kk,i1))
5914               sred_geom = sqd1*sqd2
5915               IF (sred_geom.lt.cutoff_corr) THEN
5916                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5917      &            ekont,fprimcont)
5918 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5919 c     &         ' jj=',jj,' kk=',kk
5920                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5921                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5922                 do l=1,3
5923                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5924                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5925                 enddo
5926                 n_corr1=n_corr1+1
5927 cd               write (iout,*) 'sred_geom=',sred_geom,
5928 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5929                 call calc_eello(i,j,i+1,j1,jj,kk)
5930                 if (wcorr4.gt.0.0d0)
5931      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5932                 if (wcorr5.gt.0.0d0)
5933      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5934 c                print *,"wcorr5",ecorr5
5935 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5936 cd                write(2,*)'ijkl',i,j,i+1,j1
5937                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5938      &               .or. wturn6.eq.0.0d0))then
5939 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5940                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5941 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5942 cd     &            'ecorr6=',ecorr6
5943 cd                write (iout,'(4e15.5)') sred_geom,
5944 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5945 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5946 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5947                 else if (wturn6.gt.0.0d0
5948      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5949 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5950                   eturn6=eturn6+eello_turn6(i,jj,kk)
5951 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5952                 endif
5953               ENDIF
5954 1111          continue
5955             else if (j1.eq.j) then
5956 C Contacts I-J and I-(J+1) occur simultaneously.
5957 C The system loses extra energy.
5958 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5959             endif
5960           enddo ! kk
5961           do kk=1,num_conti
5962             j1=jcont_hb(kk,i)
5963 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5964 c    &         ' jj=',jj,' kk=',kk
5965             if (j1.eq.j+1) then
5966 C Contacts I-J and (I+1)-J occur simultaneously.
5967 C The system loses extra energy.
5968 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5969             endif ! j1==j+1
5970           enddo ! kk
5971         enddo ! jj
5972       enddo ! i
5973       return
5974       end
5975 c------------------------------------------------------------------------------
5976       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5977       implicit real*8 (a-h,o-z)
5978       include 'DIMENSIONS'
5979       include 'COMMON.IOUNITS'
5980       include 'COMMON.DERIV'
5981       include 'COMMON.INTERACT'
5982       include 'COMMON.CONTACTS'
5983       include 'COMMON.SHIELD'
5984
5985       double precision gx(3),gx1(3)
5986       logical lprn
5987       lprn=.false.
5988       eij=facont_hb(jj,i)
5989       ekl=facont_hb(kk,k)
5990       ees0pij=ees0p(jj,i)
5991       ees0pkl=ees0p(kk,k)
5992       ees0mij=ees0m(jj,i)
5993       ees0mkl=ees0m(kk,k)
5994       ekont=eij*ekl
5995       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5996 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5997 C Following 4 lines for diagnostics.
5998 cd    ees0pkl=0.0D0
5999 cd    ees0pij=1.0D0
6000 cd    ees0mkl=0.0D0
6001 cd    ees0mij=1.0D0
6002 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6003 c    &   ' and',k,l
6004 c     write (iout,*)'Contacts have occurred for peptide groups',
6005 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6006 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6007 C Calculate the multi-body contribution to energy.
6008       ecorr=ecorr+ekont*ees
6009       if (calc_grad) then
6010 C Calculate multi-body contributions to the gradient.
6011       do ll=1,3
6012         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6013         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6014      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6015      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6016         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6017      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6018      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6019         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6020         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6021      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6022      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6023         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6024      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6025      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6026       enddo
6027       do m=i+1,j-1
6028         do ll=1,3
6029           gradcorr(ll,m)=gradcorr(ll,m)+
6030      &     ees*ekl*gacont_hbr(ll,jj,i)-
6031      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6032      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6033         enddo
6034       enddo
6035       do m=k+1,l-1
6036         do ll=1,3
6037           gradcorr(ll,m)=gradcorr(ll,m)+
6038      &     ees*eij*gacont_hbr(ll,kk,k)-
6039      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6040      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6041         enddo
6042       enddo
6043       if (shield_mode.gt.0) then
6044        j=ees0plist(jj,i)
6045        l=ees0plist(kk,k)
6046 C        print *,i,j,fac_shield(i),fac_shield(j),
6047 C     &fac_shield(k),fac_shield(l)
6048         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6049      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6050           do ilist=1,ishield_list(i)
6051            iresshield=shield_list(ilist,i)
6052            do m=1,3
6053            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6054 C     &      *2.0
6055            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6056      &              rlocshield
6057      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6058             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6059      &+rlocshield
6060            enddo
6061           enddo
6062           do ilist=1,ishield_list(j)
6063            iresshield=shield_list(ilist,j)
6064            do m=1,3
6065            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6066 C     &     *2.0
6067            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6068      &              rlocshield
6069      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6070            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6071      &     +rlocshield
6072            enddo
6073           enddo
6074           do ilist=1,ishield_list(k)
6075            iresshield=shield_list(ilist,k)
6076            do m=1,3
6077            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6078 C     &     *2.0
6079            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6080      &              rlocshield
6081      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6082            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6083      &     +rlocshield
6084            enddo
6085           enddo
6086           do ilist=1,ishield_list(l)
6087            iresshield=shield_list(ilist,l)
6088            do m=1,3
6089            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6090 C     &     *2.0
6091            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6092      &              rlocshield
6093      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6094            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6095      &     +rlocshield
6096            enddo
6097           enddo
6098 C          print *,gshieldx(m,iresshield)
6099           do m=1,3
6100             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6101      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6102             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6103      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6104             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6105      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6106             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6107      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6108
6109             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6110      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6111             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6112      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6113             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6114      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6115             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6116      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6117
6118            enddo
6119       endif
6120       endif
6121       endif
6122       ehbcorr=ekont*ees
6123       return
6124       end
6125 C---------------------------------------------------------------------------
6126       subroutine dipole(i,j,jj)
6127       implicit real*8 (a-h,o-z)
6128       include 'DIMENSIONS'
6129       include 'sizesclu.dat'
6130       include 'COMMON.IOUNITS'
6131       include 'COMMON.CHAIN'
6132       include 'COMMON.FFIELD'
6133       include 'COMMON.DERIV'
6134       include 'COMMON.INTERACT'
6135       include 'COMMON.CONTACTS'
6136       include 'COMMON.TORSION'
6137       include 'COMMON.VAR'
6138       include 'COMMON.GEO'
6139       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6140      &  auxmat(2,2)
6141       iti1 = itortyp(itype(i+1))
6142       if (j.lt.nres-1) then
6143         if (itype(j).le.ntyp) then
6144           itj1 = itortyp(itype(j+1))
6145         else
6146           itj1=ntortyp+1
6147         endif
6148       else
6149         itj1=ntortyp+1
6150       endif
6151       do iii=1,2
6152         dipi(iii,1)=Ub2(iii,i)
6153         dipderi(iii)=Ub2der(iii,i)
6154         dipi(iii,2)=b1(iii,iti1)
6155         dipj(iii,1)=Ub2(iii,j)
6156         dipderj(iii)=Ub2der(iii,j)
6157         dipj(iii,2)=b1(iii,itj1)
6158       enddo
6159       kkk=0
6160       do iii=1,2
6161         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6162         do jjj=1,2
6163           kkk=kkk+1
6164           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6165         enddo
6166       enddo
6167       if (.not.calc_grad) return
6168       do kkk=1,5
6169         do lll=1,3
6170           mmm=0
6171           do iii=1,2
6172             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6173      &        auxvec(1))
6174             do jjj=1,2
6175               mmm=mmm+1
6176               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6177             enddo
6178           enddo
6179         enddo
6180       enddo
6181       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6182       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6183       do iii=1,2
6184         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6185       enddo
6186       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6187       do iii=1,2
6188         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6189       enddo
6190       return
6191       end
6192 C---------------------------------------------------------------------------
6193       subroutine calc_eello(i,j,k,l,jj,kk)
6194 C
6195 C This subroutine computes matrices and vectors needed to calculate
6196 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6197 C
6198       implicit real*8 (a-h,o-z)
6199       include 'DIMENSIONS'
6200       include 'sizesclu.dat'
6201       include 'COMMON.IOUNITS'
6202       include 'COMMON.CHAIN'
6203       include 'COMMON.DERIV'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.CONTACTS'
6206       include 'COMMON.TORSION'
6207       include 'COMMON.VAR'
6208       include 'COMMON.GEO'
6209       include 'COMMON.FFIELD'
6210       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6211      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6212       logical lprn
6213       common /kutas/ lprn
6214 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6215 cd     & ' jj=',jj,' kk=',kk
6216 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6217       do iii=1,2
6218         do jjj=1,2
6219           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6220           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6221         enddo
6222       enddo
6223       call transpose2(aa1(1,1),aa1t(1,1))
6224       call transpose2(aa2(1,1),aa2t(1,1))
6225       do kkk=1,5
6226         do lll=1,3
6227           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6228      &      aa1tder(1,1,lll,kkk))
6229           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6230      &      aa2tder(1,1,lll,kkk))
6231         enddo
6232       enddo
6233       if (l.eq.j+1) then
6234 C parallel orientation of the two CA-CA-CA frames.
6235 c        if (i.gt.1) then
6236         if (i.gt.1 .and. itype(i).le.ntyp) then
6237           iti=itortyp(itype(i))
6238         else
6239           iti=ntortyp+1
6240         endif
6241         itk1=itortyp(itype(k+1))
6242         itj=itortyp(itype(j))
6243 c        if (l.lt.nres-1) then
6244         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6245           itl1=itortyp(itype(l+1))
6246         else
6247           itl1=ntortyp+1
6248         endif
6249 C A1 kernel(j+1) A2T
6250 cd        do iii=1,2
6251 cd          write (iout,'(3f10.5,5x,3f10.5)')
6252 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6253 cd        enddo
6254         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6255      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6256      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6257 C Following matrices are needed only for 6-th order cumulants
6258         IF (wcorr6.gt.0.0d0) THEN
6259         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6260      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6261      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6263      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6264      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6265      &   ADtEAderx(1,1,1,1,1,1))
6266         lprn=.false.
6267         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6268      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6269      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6270      &   ADtEA1derx(1,1,1,1,1,1))
6271         ENDIF
6272 C End 6-th order cumulants
6273 cd        lprn=.false.
6274 cd        if (lprn) then
6275 cd        write (2,*) 'In calc_eello6'
6276 cd        do iii=1,2
6277 cd          write (2,*) 'iii=',iii
6278 cd          do kkk=1,5
6279 cd            write (2,*) 'kkk=',kkk
6280 cd            do jjj=1,2
6281 cd              write (2,'(3(2f10.5),5x)')
6282 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6283 cd            enddo
6284 cd          enddo
6285 cd        enddo
6286 cd        endif
6287         call transpose2(EUgder(1,1,k),auxmat(1,1))
6288         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6289         call transpose2(EUg(1,1,k),auxmat(1,1))
6290         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6291         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6292         do iii=1,2
6293           do kkk=1,5
6294             do lll=1,3
6295               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6296      &          EAEAderx(1,1,lll,kkk,iii,1))
6297             enddo
6298           enddo
6299         enddo
6300 C A1T kernel(i+1) A2
6301         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6302      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6303      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6304 C Following matrices are needed only for 6-th order cumulants
6305         IF (wcorr6.gt.0.0d0) THEN
6306         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6307      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6308      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6309         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6310      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6311      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6312      &   ADtEAderx(1,1,1,1,1,2))
6313         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6314      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6315      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6316      &   ADtEA1derx(1,1,1,1,1,2))
6317         ENDIF
6318 C End 6-th order cumulants
6319         call transpose2(EUgder(1,1,l),auxmat(1,1))
6320         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6321         call transpose2(EUg(1,1,l),auxmat(1,1))
6322         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6323         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6324         do iii=1,2
6325           do kkk=1,5
6326             do lll=1,3
6327               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6328      &          EAEAderx(1,1,lll,kkk,iii,2))
6329             enddo
6330           enddo
6331         enddo
6332 C AEAb1 and AEAb2
6333 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6334 C They are needed only when the fifth- or the sixth-order cumulants are
6335 C indluded.
6336         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6337         call transpose2(AEA(1,1,1),auxmat(1,1))
6338         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6339         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6340         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6341         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6342         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6343         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6344         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6345         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6346         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6347         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6348         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6349         call transpose2(AEA(1,1,2),auxmat(1,1))
6350         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6351         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6352         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6353         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6354         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6355         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6356         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6357         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6358         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6359         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6360         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6361 C Calculate the Cartesian derivatives of the vectors.
6362         do iii=1,2
6363           do kkk=1,5
6364             do lll=1,3
6365               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6366               call matvec2(auxmat(1,1),b1(1,iti),
6367      &          AEAb1derx(1,lll,kkk,iii,1,1))
6368               call matvec2(auxmat(1,1),Ub2(1,i),
6369      &          AEAb2derx(1,lll,kkk,iii,1,1))
6370               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6371      &          AEAb1derx(1,lll,kkk,iii,2,1))
6372               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6373      &          AEAb2derx(1,lll,kkk,iii,2,1))
6374               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6375               call matvec2(auxmat(1,1),b1(1,itj),
6376      &          AEAb1derx(1,lll,kkk,iii,1,2))
6377               call matvec2(auxmat(1,1),Ub2(1,j),
6378      &          AEAb2derx(1,lll,kkk,iii,1,2))
6379               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6380      &          AEAb1derx(1,lll,kkk,iii,2,2))
6381               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6382      &          AEAb2derx(1,lll,kkk,iii,2,2))
6383             enddo
6384           enddo
6385         enddo
6386         ENDIF
6387 C End vectors
6388       else
6389 C Antiparallel orientation of the two CA-CA-CA frames.
6390 c        if (i.gt.1) then
6391         if (i.gt.1 .and. itype(i).le.ntyp) then
6392           iti=itortyp(itype(i))
6393         else
6394           iti=ntortyp+1
6395         endif
6396         itk1=itortyp(itype(k+1))
6397         itl=itortyp(itype(l))
6398         itj=itortyp(itype(j))
6399 c        if (j.lt.nres-1) then
6400         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6401           itj1=itortyp(itype(j+1))
6402         else
6403           itj1=ntortyp+1
6404         endif
6405 C A2 kernel(j-1)T A1T
6406         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6407      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6408      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6409 C Following matrices are needed only for 6-th order cumulants
6410         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6411      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6412         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6413      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6414      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6415         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6416      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6417      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6418      &   ADtEAderx(1,1,1,1,1,1))
6419         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6420      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6421      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6422      &   ADtEA1derx(1,1,1,1,1,1))
6423         ENDIF
6424 C End 6-th order cumulants
6425         call transpose2(EUgder(1,1,k),auxmat(1,1))
6426         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6427         call transpose2(EUg(1,1,k),auxmat(1,1))
6428         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6429         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6430         do iii=1,2
6431           do kkk=1,5
6432             do lll=1,3
6433               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6434      &          EAEAderx(1,1,lll,kkk,iii,1))
6435             enddo
6436           enddo
6437         enddo
6438 C A2T kernel(i+1)T A1
6439         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6440      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6441      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6442 C Following matrices are needed only for 6-th order cumulants
6443         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6444      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6445         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6446      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6447      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6448         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6449      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6450      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6451      &   ADtEAderx(1,1,1,1,1,2))
6452         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6453      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6454      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6455      &   ADtEA1derx(1,1,1,1,1,2))
6456         ENDIF
6457 C End 6-th order cumulants
6458         call transpose2(EUgder(1,1,j),auxmat(1,1))
6459         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6460         call transpose2(EUg(1,1,j),auxmat(1,1))
6461         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6462         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6463         do iii=1,2
6464           do kkk=1,5
6465             do lll=1,3
6466               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6467      &          EAEAderx(1,1,lll,kkk,iii,2))
6468             enddo
6469           enddo
6470         enddo
6471 C AEAb1 and AEAb2
6472 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6473 C They are needed only when the fifth- or the sixth-order cumulants are
6474 C indluded.
6475         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6476      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6477         call transpose2(AEA(1,1,1),auxmat(1,1))
6478         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6479         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6480         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6481         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6482         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6483         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6484         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6485         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6486         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6487         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6488         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6489         call transpose2(AEA(1,1,2),auxmat(1,1))
6490         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6491         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6492         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6493         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6494         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6495         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6496         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6497         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6498         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6499         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6500         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6501 C Calculate the Cartesian derivatives of the vectors.
6502         do iii=1,2
6503           do kkk=1,5
6504             do lll=1,3
6505               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6506               call matvec2(auxmat(1,1),b1(1,iti),
6507      &          AEAb1derx(1,lll,kkk,iii,1,1))
6508               call matvec2(auxmat(1,1),Ub2(1,i),
6509      &          AEAb2derx(1,lll,kkk,iii,1,1))
6510               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6511      &          AEAb1derx(1,lll,kkk,iii,2,1))
6512               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6513      &          AEAb2derx(1,lll,kkk,iii,2,1))
6514               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6515               call matvec2(auxmat(1,1),b1(1,itl),
6516      &          AEAb1derx(1,lll,kkk,iii,1,2))
6517               call matvec2(auxmat(1,1),Ub2(1,l),
6518      &          AEAb2derx(1,lll,kkk,iii,1,2))
6519               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6520      &          AEAb1derx(1,lll,kkk,iii,2,2))
6521               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6522      &          AEAb2derx(1,lll,kkk,iii,2,2))
6523             enddo
6524           enddo
6525         enddo
6526         ENDIF
6527 C End vectors
6528       endif
6529       return
6530       end
6531 C---------------------------------------------------------------------------
6532       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6533      &  KK,KKderg,AKA,AKAderg,AKAderx)
6534       implicit none
6535       integer nderg
6536       logical transp
6537       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6538      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6539      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6540       integer iii,kkk,lll
6541       integer jjj,mmm
6542       logical lprn
6543       common /kutas/ lprn
6544       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6545       do iii=1,nderg
6546         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6547      &    AKAderg(1,1,iii))
6548       enddo
6549 cd      if (lprn) write (2,*) 'In kernel'
6550       do kkk=1,5
6551 cd        if (lprn) write (2,*) 'kkk=',kkk
6552         do lll=1,3
6553           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6554      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6555 cd          if (lprn) then
6556 cd            write (2,*) 'lll=',lll
6557 cd            write (2,*) 'iii=1'
6558 cd            do jjj=1,2
6559 cd              write (2,'(3(2f10.5),5x)')
6560 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6561 cd            enddo
6562 cd          endif
6563           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6564      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6565 cd          if (lprn) then
6566 cd            write (2,*) 'lll=',lll
6567 cd            write (2,*) 'iii=2'
6568 cd            do jjj=1,2
6569 cd              write (2,'(3(2f10.5),5x)')
6570 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6571 cd            enddo
6572 cd          endif
6573         enddo
6574       enddo
6575       return
6576       end
6577 C---------------------------------------------------------------------------
6578       double precision function eello4(i,j,k,l,jj,kk)
6579       implicit real*8 (a-h,o-z)
6580       include 'DIMENSIONS'
6581       include 'sizesclu.dat'
6582       include 'COMMON.IOUNITS'
6583       include 'COMMON.CHAIN'
6584       include 'COMMON.DERIV'
6585       include 'COMMON.INTERACT'
6586       include 'COMMON.CONTACTS'
6587       include 'COMMON.TORSION'
6588       include 'COMMON.VAR'
6589       include 'COMMON.GEO'
6590       double precision pizda(2,2),ggg1(3),ggg2(3)
6591 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6592 cd        eello4=0.0d0
6593 cd        return
6594 cd      endif
6595 cd      print *,'eello4:',i,j,k,l,jj,kk
6596 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6597 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6598 cold      eij=facont_hb(jj,i)
6599 cold      ekl=facont_hb(kk,k)
6600 cold      ekont=eij*ekl
6601       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6602       if (calc_grad) then
6603 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6604       gcorr_loc(k-1)=gcorr_loc(k-1)
6605      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6606       if (l.eq.j+1) then
6607         gcorr_loc(l-1)=gcorr_loc(l-1)
6608      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6609       else
6610         gcorr_loc(j-1)=gcorr_loc(j-1)
6611      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6612       endif
6613       do iii=1,2
6614         do kkk=1,5
6615           do lll=1,3
6616             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6617      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6618 cd            derx(lll,kkk,iii)=0.0d0
6619           enddo
6620         enddo
6621       enddo
6622 cd      gcorr_loc(l-1)=0.0d0
6623 cd      gcorr_loc(j-1)=0.0d0
6624 cd      gcorr_loc(k-1)=0.0d0
6625 cd      eel4=1.0d0
6626 cd      write (iout,*)'Contacts have occurred for peptide groups',
6627 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6628 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6629       if (j.lt.nres-1) then
6630         j1=j+1
6631         j2=j-1
6632       else
6633         j1=j-1
6634         j2=j-2
6635       endif
6636       if (l.lt.nres-1) then
6637         l1=l+1
6638         l2=l-1
6639       else
6640         l1=l-1
6641         l2=l-2
6642       endif
6643       do ll=1,3
6644 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6645         ggg1(ll)=eel4*g_contij(ll,1)
6646         ggg2(ll)=eel4*g_contij(ll,2)
6647         ghalf=0.5d0*ggg1(ll)
6648 cd        ghalf=0.0d0
6649         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6650         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6651         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6652         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6653 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6654         ghalf=0.5d0*ggg2(ll)
6655 cd        ghalf=0.0d0
6656         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6657         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6658         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6659         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6660       enddo
6661 cd      goto 1112
6662       do m=i+1,j-1
6663         do ll=1,3
6664 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6665           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6666         enddo
6667       enddo
6668       do m=k+1,l-1
6669         do ll=1,3
6670 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6671           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6672         enddo
6673       enddo
6674 1112  continue
6675       do m=i+2,j2
6676         do ll=1,3
6677           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6678         enddo
6679       enddo
6680       do m=k+2,l2
6681         do ll=1,3
6682           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6683         enddo
6684       enddo
6685 cd      do iii=1,nres-3
6686 cd        write (2,*) iii,gcorr_loc(iii)
6687 cd      enddo
6688       endif
6689       eello4=ekont*eel4
6690 cd      write (2,*) 'ekont',ekont
6691 cd      write (iout,*) 'eello4',ekont*eel4
6692       return
6693       end
6694 C---------------------------------------------------------------------------
6695       double precision function eello5(i,j,k,l,jj,kk)
6696       implicit real*8 (a-h,o-z)
6697       include 'DIMENSIONS'
6698       include 'sizesclu.dat'
6699       include 'COMMON.IOUNITS'
6700       include 'COMMON.CHAIN'
6701       include 'COMMON.DERIV'
6702       include 'COMMON.INTERACT'
6703       include 'COMMON.CONTACTS'
6704       include 'COMMON.TORSION'
6705       include 'COMMON.VAR'
6706       include 'COMMON.GEO'
6707       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6708       double precision ggg1(3),ggg2(3)
6709 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6710 C                                                                              C
6711 C                            Parallel chains                                   C
6712 C                                                                              C
6713 C          o             o                   o             o                   C
6714 C         /l\           / \             \   / \           / \   /              C
6715 C        /   \         /   \             \ /   \         /   \ /               C
6716 C       j| o |l1       | o |              o| o |         | o |o                C
6717 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6718 C      \i/   \         /   \ /             /   \         /   \                 C
6719 C       o    k1             o                                                  C
6720 C         (I)          (II)                (III)          (IV)                 C
6721 C                                                                              C
6722 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6723 C                                                                              C
6724 C                            Antiparallel chains                               C
6725 C                                                                              C
6726 C          o             o                   o             o                   C
6727 C         /j\           / \             \   / \           / \   /              C
6728 C        /   \         /   \             \ /   \         /   \ /               C
6729 C      j1| o |l        | o |              o| o |         | o |o                C
6730 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6731 C      \i/   \         /   \ /             /   \         /   \                 C
6732 C       o     k1            o                                                  C
6733 C         (I)          (II)                (III)          (IV)                 C
6734 C                                                                              C
6735 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6736 C                                                                              C
6737 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6738 C                                                                              C
6739 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6740 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6741 cd        eello5=0.0d0
6742 cd        return
6743 cd      endif
6744 cd      write (iout,*)
6745 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6746 cd     &   ' and',k,l
6747       itk=itortyp(itype(k))
6748       itl=itortyp(itype(l))
6749       itj=itortyp(itype(j))
6750       eello5_1=0.0d0
6751       eello5_2=0.0d0
6752       eello5_3=0.0d0
6753       eello5_4=0.0d0
6754 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6755 cd     &   eel5_3_num,eel5_4_num)
6756       do iii=1,2
6757         do kkk=1,5
6758           do lll=1,3
6759             derx(lll,kkk,iii)=0.0d0
6760           enddo
6761         enddo
6762       enddo
6763 cd      eij=facont_hb(jj,i)
6764 cd      ekl=facont_hb(kk,k)
6765 cd      ekont=eij*ekl
6766 cd      write (iout,*)'Contacts have occurred for peptide groups',
6767 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6768 cd      goto 1111
6769 C Contribution from the graph I.
6770 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6771 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6772       call transpose2(EUg(1,1,k),auxmat(1,1))
6773       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6774       vv(1)=pizda(1,1)-pizda(2,2)
6775       vv(2)=pizda(1,2)+pizda(2,1)
6776       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6777      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6778       if (calc_grad) then
6779 C Explicit gradient in virtual-dihedral angles.
6780       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6781      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6782      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6783       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6784       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6785       vv(1)=pizda(1,1)-pizda(2,2)
6786       vv(2)=pizda(1,2)+pizda(2,1)
6787       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6788      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6789      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6790       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6791       vv(1)=pizda(1,1)-pizda(2,2)
6792       vv(2)=pizda(1,2)+pizda(2,1)
6793       if (l.eq.j+1) then
6794         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6795      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6796      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6797       else
6798         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6799      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6800      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6801       endif
6802 C Cartesian gradient
6803       do iii=1,2
6804         do kkk=1,5
6805           do lll=1,3
6806             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6807      &        pizda(1,1))
6808             vv(1)=pizda(1,1)-pizda(2,2)
6809             vv(2)=pizda(1,2)+pizda(2,1)
6810             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6811      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6812      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6813           enddo
6814         enddo
6815       enddo
6816 c      goto 1112
6817       endif
6818 c1111  continue
6819 C Contribution from graph II
6820       call transpose2(EE(1,1,itk),auxmat(1,1))
6821       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6822       vv(1)=pizda(1,1)+pizda(2,2)
6823       vv(2)=pizda(2,1)-pizda(1,2)
6824       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6825      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6826       if (calc_grad) then
6827 C Explicit gradient in virtual-dihedral angles.
6828       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6829      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6830       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6831       vv(1)=pizda(1,1)+pizda(2,2)
6832       vv(2)=pizda(2,1)-pizda(1,2)
6833       if (l.eq.j+1) then
6834         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6835      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6836      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6837       else
6838         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6839      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6840      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6841       endif
6842 C Cartesian gradient
6843       do iii=1,2
6844         do kkk=1,5
6845           do lll=1,3
6846             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6847      &        pizda(1,1))
6848             vv(1)=pizda(1,1)+pizda(2,2)
6849             vv(2)=pizda(2,1)-pizda(1,2)
6850             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6851      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6852      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6853           enddo
6854         enddo
6855       enddo
6856 cd      goto 1112
6857       endif
6858 cd1111  continue
6859       if (l.eq.j+1) then
6860 cd        goto 1110
6861 C Parallel orientation
6862 C Contribution from graph III
6863         call transpose2(EUg(1,1,l),auxmat(1,1))
6864         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6865         vv(1)=pizda(1,1)-pizda(2,2)
6866         vv(2)=pizda(1,2)+pizda(2,1)
6867         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6868      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6869         if (calc_grad) then
6870 C Explicit gradient in virtual-dihedral angles.
6871         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6872      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6873      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6874         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6875         vv(1)=pizda(1,1)-pizda(2,2)
6876         vv(2)=pizda(1,2)+pizda(2,1)
6877         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6878      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6879      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6880         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6881         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6882         vv(1)=pizda(1,1)-pizda(2,2)
6883         vv(2)=pizda(1,2)+pizda(2,1)
6884         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6885      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6886      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6887 C Cartesian gradient
6888         do iii=1,2
6889           do kkk=1,5
6890             do lll=1,3
6891               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6892      &          pizda(1,1))
6893               vv(1)=pizda(1,1)-pizda(2,2)
6894               vv(2)=pizda(1,2)+pizda(2,1)
6895               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6896      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6897      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6898             enddo
6899           enddo
6900         enddo
6901 cd        goto 1112
6902         endif
6903 C Contribution from graph IV
6904 cd1110    continue
6905         call transpose2(EE(1,1,itl),auxmat(1,1))
6906         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6907         vv(1)=pizda(1,1)+pizda(2,2)
6908         vv(2)=pizda(2,1)-pizda(1,2)
6909         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6910      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6911         if (calc_grad) then
6912 C Explicit gradient in virtual-dihedral angles.
6913         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6914      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6915         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6916         vv(1)=pizda(1,1)+pizda(2,2)
6917         vv(2)=pizda(2,1)-pizda(1,2)
6918         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6919      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6920      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6921 C Cartesian gradient
6922         do iii=1,2
6923           do kkk=1,5
6924             do lll=1,3
6925               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6926      &          pizda(1,1))
6927               vv(1)=pizda(1,1)+pizda(2,2)
6928               vv(2)=pizda(2,1)-pizda(1,2)
6929               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6930      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6931      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6932             enddo
6933           enddo
6934         enddo
6935         endif
6936       else
6937 C Antiparallel orientation
6938 C Contribution from graph III
6939 c        goto 1110
6940         call transpose2(EUg(1,1,j),auxmat(1,1))
6941         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6942         vv(1)=pizda(1,1)-pizda(2,2)
6943         vv(2)=pizda(1,2)+pizda(2,1)
6944         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6945      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6946         if (calc_grad) then
6947 C Explicit gradient in virtual-dihedral angles.
6948         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6949      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6950      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6951         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6952         vv(1)=pizda(1,1)-pizda(2,2)
6953         vv(2)=pizda(1,2)+pizda(2,1)
6954         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6955      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6956      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6957         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6958         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6959         vv(1)=pizda(1,1)-pizda(2,2)
6960         vv(2)=pizda(1,2)+pizda(2,1)
6961         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6962      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6963      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6964 C Cartesian gradient
6965         do iii=1,2
6966           do kkk=1,5
6967             do lll=1,3
6968               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6969      &          pizda(1,1))
6970               vv(1)=pizda(1,1)-pizda(2,2)
6971               vv(2)=pizda(1,2)+pizda(2,1)
6972               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6973      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6974      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6975             enddo
6976           enddo
6977         enddo
6978 cd        goto 1112
6979         endif
6980 C Contribution from graph IV
6981 1110    continue
6982         call transpose2(EE(1,1,itj),auxmat(1,1))
6983         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6984         vv(1)=pizda(1,1)+pizda(2,2)
6985         vv(2)=pizda(2,1)-pizda(1,2)
6986         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6987      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6988         if (calc_grad) then
6989 C Explicit gradient in virtual-dihedral angles.
6990         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6991      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6992         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6993         vv(1)=pizda(1,1)+pizda(2,2)
6994         vv(2)=pizda(2,1)-pizda(1,2)
6995         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6996      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6997      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6998 C Cartesian gradient
6999         do iii=1,2
7000           do kkk=1,5
7001             do lll=1,3
7002               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7003      &          pizda(1,1))
7004               vv(1)=pizda(1,1)+pizda(2,2)
7005               vv(2)=pizda(2,1)-pizda(1,2)
7006               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7007      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7008      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7009             enddo
7010           enddo
7011         enddo
7012       endif
7013       endif
7014 1112  continue
7015       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7016 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7017 cd        write (2,*) 'ijkl',i,j,k,l
7018 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7019 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7020 cd      endif
7021 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7022 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7023 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7024 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7025       if (calc_grad) then
7026       if (j.lt.nres-1) then
7027         j1=j+1
7028         j2=j-1
7029       else
7030         j1=j-1
7031         j2=j-2
7032       endif
7033       if (l.lt.nres-1) then
7034         l1=l+1
7035         l2=l-1
7036       else
7037         l1=l-1
7038         l2=l-2
7039       endif
7040 cd      eij=1.0d0
7041 cd      ekl=1.0d0
7042 cd      ekont=1.0d0
7043 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7044       do ll=1,3
7045         ggg1(ll)=eel5*g_contij(ll,1)
7046         ggg2(ll)=eel5*g_contij(ll,2)
7047 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7048         ghalf=0.5d0*ggg1(ll)
7049 cd        ghalf=0.0d0
7050         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7051         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7052         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7053         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7054 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7055         ghalf=0.5d0*ggg2(ll)
7056 cd        ghalf=0.0d0
7057         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7058         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7059         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7060         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7061       enddo
7062 cd      goto 1112
7063       do m=i+1,j-1
7064         do ll=1,3
7065 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7066           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7067         enddo
7068       enddo
7069       do m=k+1,l-1
7070         do ll=1,3
7071 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7072           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7073         enddo
7074       enddo
7075 c1112  continue
7076       do m=i+2,j2
7077         do ll=1,3
7078           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7079         enddo
7080       enddo
7081       do m=k+2,l2
7082         do ll=1,3
7083           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7084         enddo
7085       enddo
7086 cd      do iii=1,nres-3
7087 cd        write (2,*) iii,g_corr5_loc(iii)
7088 cd      enddo
7089       endif
7090       eello5=ekont*eel5
7091 cd      write (2,*) 'ekont',ekont
7092 cd      write (iout,*) 'eello5',ekont*eel5
7093       return
7094       end
7095 c--------------------------------------------------------------------------
7096       double precision function eello6(i,j,k,l,jj,kk)
7097       implicit real*8 (a-h,o-z)
7098       include 'DIMENSIONS'
7099       include 'sizesclu.dat'
7100       include 'COMMON.IOUNITS'
7101       include 'COMMON.CHAIN'
7102       include 'COMMON.DERIV'
7103       include 'COMMON.INTERACT'
7104       include 'COMMON.CONTACTS'
7105       include 'COMMON.TORSION'
7106       include 'COMMON.VAR'
7107       include 'COMMON.GEO'
7108       include 'COMMON.FFIELD'
7109       double precision ggg1(3),ggg2(3)
7110 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7111 cd        eello6=0.0d0
7112 cd        return
7113 cd      endif
7114 cd      write (iout,*)
7115 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7116 cd     &   ' and',k,l
7117       eello6_1=0.0d0
7118       eello6_2=0.0d0
7119       eello6_3=0.0d0
7120       eello6_4=0.0d0
7121       eello6_5=0.0d0
7122       eello6_6=0.0d0
7123 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7124 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7125       do iii=1,2
7126         do kkk=1,5
7127           do lll=1,3
7128             derx(lll,kkk,iii)=0.0d0
7129           enddo
7130         enddo
7131       enddo
7132 cd      eij=facont_hb(jj,i)
7133 cd      ekl=facont_hb(kk,k)
7134 cd      ekont=eij*ekl
7135 cd      eij=1.0d0
7136 cd      ekl=1.0d0
7137 cd      ekont=1.0d0
7138       if (l.eq.j+1) then
7139         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7140         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7141         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7142         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7143         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7144         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7145       else
7146         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7147         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7148         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7149         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7150         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7151           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7152         else
7153           eello6_5=0.0d0
7154         endif
7155         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7156       endif
7157 C If turn contributions are considered, they will be handled separately.
7158       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7159 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7160 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7161 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7162 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7163 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7164 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7165 cd      goto 1112
7166       if (calc_grad) then
7167       if (j.lt.nres-1) then
7168         j1=j+1
7169         j2=j-1
7170       else
7171         j1=j-1
7172         j2=j-2
7173       endif
7174       if (l.lt.nres-1) then
7175         l1=l+1
7176         l2=l-1
7177       else
7178         l1=l-1
7179         l2=l-2
7180       endif
7181       do ll=1,3
7182         ggg1(ll)=eel6*g_contij(ll,1)
7183         ggg2(ll)=eel6*g_contij(ll,2)
7184 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7185         ghalf=0.5d0*ggg1(ll)
7186 cd        ghalf=0.0d0
7187         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7188         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7189         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7190         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7191         ghalf=0.5d0*ggg2(ll)
7192 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7193 cd        ghalf=0.0d0
7194         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7195         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7196         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7197         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7198       enddo
7199 cd      goto 1112
7200       do m=i+1,j-1
7201         do ll=1,3
7202 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7203           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7204         enddo
7205       enddo
7206       do m=k+1,l-1
7207         do ll=1,3
7208 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7209           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7210         enddo
7211       enddo
7212 1112  continue
7213       do m=i+2,j2
7214         do ll=1,3
7215           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7216         enddo
7217       enddo
7218       do m=k+2,l2
7219         do ll=1,3
7220           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7221         enddo
7222       enddo
7223 cd      do iii=1,nres-3
7224 cd        write (2,*) iii,g_corr6_loc(iii)
7225 cd      enddo
7226       endif
7227       eello6=ekont*eel6
7228 cd      write (2,*) 'ekont',ekont
7229 cd      write (iout,*) 'eello6',ekont*eel6
7230       return
7231       end
7232 c--------------------------------------------------------------------------
7233       double precision function eello6_graph1(i,j,k,l,imat,swap)
7234       implicit real*8 (a-h,o-z)
7235       include 'DIMENSIONS'
7236       include 'sizesclu.dat'
7237       include 'COMMON.IOUNITS'
7238       include 'COMMON.CHAIN'
7239       include 'COMMON.DERIV'
7240       include 'COMMON.INTERACT'
7241       include 'COMMON.CONTACTS'
7242       include 'COMMON.TORSION'
7243       include 'COMMON.VAR'
7244       include 'COMMON.GEO'
7245       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7246       logical swap
7247       logical lprn
7248       common /kutas/ lprn
7249 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7250 C                                                                              C
7251 C      Parallel       Antiparallel                                             C
7252 C                                                                              C
7253 C          o             o                                                     C
7254 C         /l\           /j\                                                    C
7255 C        /   \         /   \                                                   C
7256 C       /| o |         | o |\                                                  C
7257 C     \ j|/k\|  /   \  |/k\|l /                                                C
7258 C      \ /   \ /     \ /   \ /                                                 C
7259 C       o     o       o     o                                                  C
7260 C       i             i                                                        C
7261 C                                                                              C
7262 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7263       itk=itortyp(itype(k))
7264       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7265       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7266       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7267       call transpose2(EUgC(1,1,k),auxmat(1,1))
7268       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7269       vv1(1)=pizda1(1,1)-pizda1(2,2)
7270       vv1(2)=pizda1(1,2)+pizda1(2,1)
7271       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7272       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7273       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7274       s5=scalar2(vv(1),Dtobr2(1,i))
7275 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7276       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7277       if (.not. calc_grad) return
7278       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7279      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7280      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7281      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7282      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7283      & +scalar2(vv(1),Dtobr2der(1,i)))
7284       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7285       vv1(1)=pizda1(1,1)-pizda1(2,2)
7286       vv1(2)=pizda1(1,2)+pizda1(2,1)
7287       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7288       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7289       if (l.eq.j+1) then
7290         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7291      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7292      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7293      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7294      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7295       else
7296         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7297      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7298      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7299      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7300      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7301       endif
7302       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7303       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7304       vv1(1)=pizda1(1,1)-pizda1(2,2)
7305       vv1(2)=pizda1(1,2)+pizda1(2,1)
7306       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7307      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7308      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7309      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7310       do iii=1,2
7311         if (swap) then
7312           ind=3-iii
7313         else
7314           ind=iii
7315         endif
7316         do kkk=1,5
7317           do lll=1,3
7318             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7319             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7320             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7321             call transpose2(EUgC(1,1,k),auxmat(1,1))
7322             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7323      &        pizda1(1,1))
7324             vv1(1)=pizda1(1,1)-pizda1(2,2)
7325             vv1(2)=pizda1(1,2)+pizda1(2,1)
7326             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7327             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7328      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7329             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7330      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7331             s5=scalar2(vv(1),Dtobr2(1,i))
7332             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7333           enddo
7334         enddo
7335       enddo
7336       return
7337       end
7338 c----------------------------------------------------------------------------
7339       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7340       implicit real*8 (a-h,o-z)
7341       include 'DIMENSIONS'
7342       include 'sizesclu.dat'
7343       include 'COMMON.IOUNITS'
7344       include 'COMMON.CHAIN'
7345       include 'COMMON.DERIV'
7346       include 'COMMON.INTERACT'
7347       include 'COMMON.CONTACTS'
7348       include 'COMMON.TORSION'
7349       include 'COMMON.VAR'
7350       include 'COMMON.GEO'
7351       logical swap
7352       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7353      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7354       logical lprn
7355       common /kutas/ lprn
7356 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7357 C                                                                              C
7358 C      Parallel       Antiparallel                                             C
7359 C                                                                              C
7360 C          o             o                                                     C
7361 C     \   /l\           /j\   /                                                C
7362 C      \ /   \         /   \ /                                                 C
7363 C       o| o |         | o |o                                                  C
7364 C     \ j|/k\|      \  |/k\|l                                                  C
7365 C      \ /   \       \ /   \                                                   C
7366 C       o             o                                                        C
7367 C       i             i                                                        C
7368 C                                                                              C
7369 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7370 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7371 C AL 7/4/01 s1 would occur in the sixth-order moment,
7372 C           but not in a cluster cumulant
7373 #ifdef MOMENT
7374       s1=dip(1,jj,i)*dip(1,kk,k)
7375 #endif
7376       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7377       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7378       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7379       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7380       call transpose2(EUg(1,1,k),auxmat(1,1))
7381       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7382       vv(1)=pizda(1,1)-pizda(2,2)
7383       vv(2)=pizda(1,2)+pizda(2,1)
7384       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7385 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7386 #ifdef MOMENT
7387       eello6_graph2=-(s1+s2+s3+s4)
7388 #else
7389       eello6_graph2=-(s2+s3+s4)
7390 #endif
7391 c      eello6_graph2=-s3
7392       if (.not. calc_grad) return
7393 C Derivatives in gamma(i-1)
7394       if (i.gt.1) then
7395 #ifdef MOMENT
7396         s1=dipderg(1,jj,i)*dip(1,kk,k)
7397 #endif
7398         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7399         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7400         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7401         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7402 #ifdef MOMENT
7403         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7404 #else
7405         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7406 #endif
7407 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7408       endif
7409 C Derivatives in gamma(k-1)
7410 #ifdef MOMENT
7411       s1=dip(1,jj,i)*dipderg(1,kk,k)
7412 #endif
7413       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7414       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7415       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7416       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7417       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7418       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7419       vv(1)=pizda(1,1)-pizda(2,2)
7420       vv(2)=pizda(1,2)+pizda(2,1)
7421       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7422 #ifdef MOMENT
7423       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7424 #else
7425       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7426 #endif
7427 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7428 C Derivatives in gamma(j-1) or gamma(l-1)
7429       if (j.gt.1) then
7430 #ifdef MOMENT
7431         s1=dipderg(3,jj,i)*dip(1,kk,k)
7432 #endif
7433         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7434         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7435         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7436         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7437         vv(1)=pizda(1,1)-pizda(2,2)
7438         vv(2)=pizda(1,2)+pizda(2,1)
7439         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7440 #ifdef MOMENT
7441         if (swap) then
7442           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7443         else
7444           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7445         endif
7446 #endif
7447         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7448 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7449       endif
7450 C Derivatives in gamma(l-1) or gamma(j-1)
7451       if (l.gt.1) then
7452 #ifdef MOMENT
7453         s1=dip(1,jj,i)*dipderg(3,kk,k)
7454 #endif
7455         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7456         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7457         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7458         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7459         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7460         vv(1)=pizda(1,1)-pizda(2,2)
7461         vv(2)=pizda(1,2)+pizda(2,1)
7462         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7463 #ifdef MOMENT
7464         if (swap) then
7465           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7466         else
7467           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7468         endif
7469 #endif
7470         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7471 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7472       endif
7473 C Cartesian derivatives.
7474       if (lprn) then
7475         write (2,*) 'In eello6_graph2'
7476         do iii=1,2
7477           write (2,*) 'iii=',iii
7478           do kkk=1,5
7479             write (2,*) 'kkk=',kkk
7480             do jjj=1,2
7481               write (2,'(3(2f10.5),5x)')
7482      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7483             enddo
7484           enddo
7485         enddo
7486       endif
7487       do iii=1,2
7488         do kkk=1,5
7489           do lll=1,3
7490 #ifdef MOMENT
7491             if (iii.eq.1) then
7492               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7493             else
7494               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7495             endif
7496 #endif
7497             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7498      &        auxvec(1))
7499             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7500             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7501      &        auxvec(1))
7502             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7503             call transpose2(EUg(1,1,k),auxmat(1,1))
7504             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7505      &        pizda(1,1))
7506             vv(1)=pizda(1,1)-pizda(2,2)
7507             vv(2)=pizda(1,2)+pizda(2,1)
7508             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7509 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7510 #ifdef MOMENT
7511             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7512 #else
7513             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7514 #endif
7515             if (swap) then
7516               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7517             else
7518               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7519             endif
7520           enddo
7521         enddo
7522       enddo
7523       return
7524       end
7525 c----------------------------------------------------------------------------
7526       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7527       implicit real*8 (a-h,o-z)
7528       include 'DIMENSIONS'
7529       include 'sizesclu.dat'
7530       include 'COMMON.IOUNITS'
7531       include 'COMMON.CHAIN'
7532       include 'COMMON.DERIV'
7533       include 'COMMON.INTERACT'
7534       include 'COMMON.CONTACTS'
7535       include 'COMMON.TORSION'
7536       include 'COMMON.VAR'
7537       include 'COMMON.GEO'
7538       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7539       logical swap
7540 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7541 C                                                                              C
7542 C      Parallel       Antiparallel                                             C
7543 C                                                                              C
7544 C          o             o                                                     C
7545 C         /l\   /   \   /j\                                                    C
7546 C        /   \ /     \ /   \                                                   C
7547 C       /| o |o       o| o |\                                                  C
7548 C       j|/k\|  /      |/k\|l /                                                C
7549 C        /   \ /       /   \ /                                                 C
7550 C       /     o       /     o                                                  C
7551 C       i             i                                                        C
7552 C                                                                              C
7553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7554 C
7555 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7556 C           energy moment and not to the cluster cumulant.
7557       iti=itortyp(itype(i))
7558 c      if (j.lt.nres-1) then
7559       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7560         itj1=itortyp(itype(j+1))
7561       else
7562         itj1=ntortyp+1
7563       endif
7564       itk=itortyp(itype(k))
7565       itk1=itortyp(itype(k+1))
7566 c      if (l.lt.nres-1) then
7567       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7568         itl1=itortyp(itype(l+1))
7569       else
7570         itl1=ntortyp+1
7571       endif
7572 #ifdef MOMENT
7573       s1=dip(4,jj,i)*dip(4,kk,k)
7574 #endif
7575       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7576       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7577       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7578       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7579       call transpose2(EE(1,1,itk),auxmat(1,1))
7580       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7581       vv(1)=pizda(1,1)+pizda(2,2)
7582       vv(2)=pizda(2,1)-pizda(1,2)
7583       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7584 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7585 #ifdef MOMENT
7586       eello6_graph3=-(s1+s2+s3+s4)
7587 #else
7588       eello6_graph3=-(s2+s3+s4)
7589 #endif
7590 c      eello6_graph3=-s4
7591       if (.not. calc_grad) return
7592 C Derivatives in gamma(k-1)
7593       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7594       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7595       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7596       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7597 C Derivatives in gamma(l-1)
7598       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7599       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7600       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7601       vv(1)=pizda(1,1)+pizda(2,2)
7602       vv(2)=pizda(2,1)-pizda(1,2)
7603       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7604       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7605 C Cartesian derivatives.
7606       do iii=1,2
7607         do kkk=1,5
7608           do lll=1,3
7609 #ifdef MOMENT
7610             if (iii.eq.1) then
7611               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7612             else
7613               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7614             endif
7615 #endif
7616             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7617      &        auxvec(1))
7618             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7619             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7620      &        auxvec(1))
7621             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7622             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7623      &        pizda(1,1))
7624             vv(1)=pizda(1,1)+pizda(2,2)
7625             vv(2)=pizda(2,1)-pizda(1,2)
7626             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7627 #ifdef MOMENT
7628             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7629 #else
7630             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7631 #endif
7632             if (swap) then
7633               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7634             else
7635               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7636             endif
7637 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7638           enddo
7639         enddo
7640       enddo
7641       return
7642       end
7643 c----------------------------------------------------------------------------
7644       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7645       implicit real*8 (a-h,o-z)
7646       include 'DIMENSIONS'
7647       include 'sizesclu.dat'
7648       include 'COMMON.IOUNITS'
7649       include 'COMMON.CHAIN'
7650       include 'COMMON.DERIV'
7651       include 'COMMON.INTERACT'
7652       include 'COMMON.CONTACTS'
7653       include 'COMMON.TORSION'
7654       include 'COMMON.VAR'
7655       include 'COMMON.GEO'
7656       include 'COMMON.FFIELD'
7657       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7658      & auxvec1(2),auxmat1(2,2)
7659       logical swap
7660 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7661 C                                                                              C
7662 C      Parallel       Antiparallel                                             C
7663 C                                                                              C
7664 C          o             o                                                     C
7665 C         /l\   /   \   /j\                                                    C
7666 C        /   \ /     \ /   \                                                   C
7667 C       /| o |o       o| o |\                                                  C
7668 C     \ j|/k\|      \  |/k\|l                                                  C
7669 C      \ /   \       \ /   \                                                   C
7670 C       o     \       o     \                                                  C
7671 C       i             i                                                        C
7672 C                                                                              C
7673 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7674 C
7675 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7676 C           energy moment and not to the cluster cumulant.
7677 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7678       iti=itortyp(itype(i))
7679       itj=itortyp(itype(j))
7680 c      if (j.lt.nres-1) then
7681       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7682         itj1=itortyp(itype(j+1))
7683       else
7684         itj1=ntortyp+1
7685       endif
7686       itk=itortyp(itype(k))
7687 c      if (k.lt.nres-1) then
7688       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7689         itk1=itortyp(itype(k+1))
7690       else
7691         itk1=ntortyp+1
7692       endif
7693       itl=itortyp(itype(l))
7694       if (l.lt.nres-1) then
7695         itl1=itortyp(itype(l+1))
7696       else
7697         itl1=ntortyp+1
7698       endif
7699 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7700 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7701 cd     & ' itl',itl,' itl1',itl1
7702 #ifdef MOMENT
7703       if (imat.eq.1) then
7704         s1=dip(3,jj,i)*dip(3,kk,k)
7705       else
7706         s1=dip(2,jj,j)*dip(2,kk,l)
7707       endif
7708 #endif
7709       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7710       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7711       if (j.eq.l+1) then
7712         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7713         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7714       else
7715         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7716         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7717       endif
7718       call transpose2(EUg(1,1,k),auxmat(1,1))
7719       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7720       vv(1)=pizda(1,1)-pizda(2,2)
7721       vv(2)=pizda(2,1)+pizda(1,2)
7722       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7723 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7724 #ifdef MOMENT
7725       eello6_graph4=-(s1+s2+s3+s4)
7726 #else
7727       eello6_graph4=-(s2+s3+s4)
7728 #endif
7729       if (.not. calc_grad) return
7730 C Derivatives in gamma(i-1)
7731       if (i.gt.1) then
7732 #ifdef MOMENT
7733         if (imat.eq.1) then
7734           s1=dipderg(2,jj,i)*dip(3,kk,k)
7735         else
7736           s1=dipderg(4,jj,j)*dip(2,kk,l)
7737         endif
7738 #endif
7739         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7740         if (j.eq.l+1) then
7741           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7742           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7743         else
7744           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7745           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7746         endif
7747         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7748         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7749 cd          write (2,*) 'turn6 derivatives'
7750 #ifdef MOMENT
7751           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7752 #else
7753           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7754 #endif
7755         else
7756 #ifdef MOMENT
7757           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7758 #else
7759           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7760 #endif
7761         endif
7762       endif
7763 C Derivatives in gamma(k-1)
7764 #ifdef MOMENT
7765       if (imat.eq.1) then
7766         s1=dip(3,jj,i)*dipderg(2,kk,k)
7767       else
7768         s1=dip(2,jj,j)*dipderg(4,kk,l)
7769       endif
7770 #endif
7771       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7772       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7773       if (j.eq.l+1) then
7774         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7775         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7776       else
7777         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7778         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7779       endif
7780       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7781       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7782       vv(1)=pizda(1,1)-pizda(2,2)
7783       vv(2)=pizda(2,1)+pizda(1,2)
7784       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7785       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7786 #ifdef MOMENT
7787         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7788 #else
7789         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7790 #endif
7791       else
7792 #ifdef MOMENT
7793         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7794 #else
7795         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7796 #endif
7797       endif
7798 C Derivatives in gamma(j-1) or gamma(l-1)
7799       if (l.eq.j+1 .and. l.gt.1) then
7800         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7801         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7802         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7803         vv(1)=pizda(1,1)-pizda(2,2)
7804         vv(2)=pizda(2,1)+pizda(1,2)
7805         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7806         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7807       else if (j.gt.1) then
7808         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7809         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7810         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7811         vv(1)=pizda(1,1)-pizda(2,2)
7812         vv(2)=pizda(2,1)+pizda(1,2)
7813         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7814         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7815           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7816         else
7817           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7818         endif
7819       endif
7820 C Cartesian derivatives.
7821       do iii=1,2
7822         do kkk=1,5
7823           do lll=1,3
7824 #ifdef MOMENT
7825             if (iii.eq.1) then
7826               if (imat.eq.1) then
7827                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7828               else
7829                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7830               endif
7831             else
7832               if (imat.eq.1) then
7833                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7834               else
7835                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7836               endif
7837             endif
7838 #endif
7839             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7840      &        auxvec(1))
7841             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7842             if (j.eq.l+1) then
7843               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7844      &          b1(1,itj1),auxvec(1))
7845               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7846             else
7847               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7848      &          b1(1,itl1),auxvec(1))
7849               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7850             endif
7851             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,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),Dtobr2(1,i))
7856             if (swap) then
7857               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7858 #ifdef MOMENT
7859                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7860      &             -(s1+s2+s4)
7861 #else
7862                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7863      &             -(s2+s4)
7864 #endif
7865                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7866               else
7867 #ifdef MOMENT
7868                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7869 #else
7870                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7871 #endif
7872                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7873               endif
7874             else
7875 #ifdef MOMENT
7876               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7877 #else
7878               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7879 #endif
7880               if (l.eq.j+1) then
7881                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7882               else
7883                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7884               endif
7885             endif
7886           enddo
7887         enddo
7888       enddo
7889       return
7890       end
7891 c----------------------------------------------------------------------------
7892       double precision function eello_turn6(i,jj,kk)
7893       implicit real*8 (a-h,o-z)
7894       include 'DIMENSIONS'
7895       include 'sizesclu.dat'
7896       include 'COMMON.IOUNITS'
7897       include 'COMMON.CHAIN'
7898       include 'COMMON.DERIV'
7899       include 'COMMON.INTERACT'
7900       include 'COMMON.CONTACTS'
7901       include 'COMMON.TORSION'
7902       include 'COMMON.VAR'
7903       include 'COMMON.GEO'
7904       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7905      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7906      &  ggg1(3),ggg2(3)
7907       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7908      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7909 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7910 C           the respective energy moment and not to the cluster cumulant.
7911       eello_turn6=0.0d0
7912       j=i+4
7913       k=i+1
7914       l=i+3
7915       iti=itortyp(itype(i))
7916       itk=itortyp(itype(k))
7917       itk1=itortyp(itype(k+1))
7918       itl=itortyp(itype(l))
7919       itj=itortyp(itype(j))
7920 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7921 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7922 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7923 cd        eello6=0.0d0
7924 cd        return
7925 cd      endif
7926 cd      write (iout,*)
7927 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7928 cd     &   ' and',k,l
7929 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7930       do iii=1,2
7931         do kkk=1,5
7932           do lll=1,3
7933             derx_turn(lll,kkk,iii)=0.0d0
7934           enddo
7935         enddo
7936       enddo
7937 cd      eij=1.0d0
7938 cd      ekl=1.0d0
7939 cd      ekont=1.0d0
7940       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7941 cd      eello6_5=0.0d0
7942 cd      write (2,*) 'eello6_5',eello6_5
7943 #ifdef MOMENT
7944       call transpose2(AEA(1,1,1),auxmat(1,1))
7945       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7946       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7947       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7948 #else
7949       s1 = 0.0d0
7950 #endif
7951       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7952       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7953       s2 = scalar2(b1(1,itk),vtemp1(1))
7954 #ifdef MOMENT
7955       call transpose2(AEA(1,1,2),atemp(1,1))
7956       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7957       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7958       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7959 #else
7960       s8=0.0d0
7961 #endif
7962       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7963       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7964       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7965 #ifdef MOMENT
7966       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7967       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7968       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7969       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7970       ss13 = scalar2(b1(1,itk),vtemp4(1))
7971       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7972 #else
7973       s13=0.0d0
7974 #endif
7975 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7976 c      s1=0.0d0
7977 c      s2=0.0d0
7978 c      s8=0.0d0
7979 c      s12=0.0d0
7980 c      s13=0.0d0
7981       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7982       if (calc_grad) then
7983 C Derivatives in gamma(i+2)
7984 #ifdef MOMENT
7985       call transpose2(AEA(1,1,1),auxmatd(1,1))
7986       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7987       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7988       call transpose2(AEAderg(1,1,2),atempd(1,1))
7989       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7990       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7991 #else
7992       s8d=0.0d0
7993 #endif
7994       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7995       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7996       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7997 c      s1d=0.0d0
7998 c      s2d=0.0d0
7999 c      s8d=0.0d0
8000 c      s12d=0.0d0
8001 c      s13d=0.0d0
8002       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8003 C Derivatives in gamma(i+3)
8004 #ifdef MOMENT
8005       call transpose2(AEA(1,1,1),auxmatd(1,1))
8006       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8007       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8008       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8009 #else
8010       s1d=0.0d0
8011 #endif
8012       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8013       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8014       s2d = scalar2(b1(1,itk),vtemp1d(1))
8015 #ifdef MOMENT
8016       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8017       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8018 #endif
8019       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8020 #ifdef MOMENT
8021       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8022       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8023       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8024 #else
8025       s13d=0.0d0
8026 #endif
8027 c      s1d=0.0d0
8028 c      s2d=0.0d0
8029 c      s8d=0.0d0
8030 c      s12d=0.0d0
8031 c      s13d=0.0d0
8032 #ifdef MOMENT
8033       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8034      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8035 #else
8036       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8037      &               -0.5d0*ekont*(s2d+s12d)
8038 #endif
8039 C Derivatives in gamma(i+4)
8040       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8041       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8042       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8043 #ifdef MOMENT
8044       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8045       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8046       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8047 #else
8048       s13d = 0.0d0
8049 #endif
8050 c      s1d=0.0d0
8051 c      s2d=0.0d0
8052 c      s8d=0.0d0
8053 C      s12d=0.0d0
8054 c      s13d=0.0d0
8055 #ifdef MOMENT
8056       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8057 #else
8058       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8059 #endif
8060 C Derivatives in gamma(i+5)
8061 #ifdef MOMENT
8062       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8063       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8064       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8065 #else
8066       s1d = 0.0d0
8067 #endif
8068       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8069       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8070       s2d = scalar2(b1(1,itk),vtemp1d(1))
8071 #ifdef MOMENT
8072       call transpose2(AEA(1,1,2),atempd(1,1))
8073       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8074       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8075 #else
8076       s8d = 0.0d0
8077 #endif
8078       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8079       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8080 #ifdef MOMENT
8081       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8082       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8083       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8084 #else
8085       s13d = 0.0d0
8086 #endif
8087 c      s1d=0.0d0
8088 c      s2d=0.0d0
8089 c      s8d=0.0d0
8090 c      s12d=0.0d0
8091 c      s13d=0.0d0
8092 #ifdef MOMENT
8093       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8094      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8095 #else
8096       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8097      &               -0.5d0*ekont*(s2d+s12d)
8098 #endif
8099 C Cartesian derivatives
8100       do iii=1,2
8101         do kkk=1,5
8102           do lll=1,3
8103 #ifdef MOMENT
8104             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8105             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8106             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8107 #else
8108             s1d = 0.0d0
8109 #endif
8110             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8111             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8112      &          vtemp1d(1))
8113             s2d = scalar2(b1(1,itk),vtemp1d(1))
8114 #ifdef MOMENT
8115             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8116             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8117             s8d = -(atempd(1,1)+atempd(2,2))*
8118      &           scalar2(cc(1,1,itl),vtemp2(1))
8119 #else
8120             s8d = 0.0d0
8121 #endif
8122             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8123      &           auxmatd(1,1))
8124             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8125             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8126 c      s1d=0.0d0
8127 c      s2d=0.0d0
8128 c      s8d=0.0d0
8129 c      s12d=0.0d0
8130 c      s13d=0.0d0
8131 #ifdef MOMENT
8132             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8133      &        - 0.5d0*(s1d+s2d)
8134 #else
8135             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8136      &        - 0.5d0*s2d
8137 #endif
8138 #ifdef MOMENT
8139             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8140      &        - 0.5d0*(s8d+s12d)
8141 #else
8142             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8143      &        - 0.5d0*s12d
8144 #endif
8145           enddo
8146         enddo
8147       enddo
8148 #ifdef MOMENT
8149       do kkk=1,5
8150         do lll=1,3
8151           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8152      &      achuj_tempd(1,1))
8153           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8154           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8155           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8156           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8157           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8158      &      vtemp4d(1))
8159           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8160           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8161           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8162         enddo
8163       enddo
8164 #endif
8165 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8166 cd     &  16*eel_turn6_num
8167 cd      goto 1112
8168       if (j.lt.nres-1) then
8169         j1=j+1
8170         j2=j-1
8171       else
8172         j1=j-1
8173         j2=j-2
8174       endif
8175       if (l.lt.nres-1) then
8176         l1=l+1
8177         l2=l-1
8178       else
8179         l1=l-1
8180         l2=l-2
8181       endif
8182       do ll=1,3
8183         ggg1(ll)=eel_turn6*g_contij(ll,1)
8184         ggg2(ll)=eel_turn6*g_contij(ll,2)
8185         ghalf=0.5d0*ggg1(ll)
8186 cd        ghalf=0.0d0
8187         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8188      &    +ekont*derx_turn(ll,2,1)
8189         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8190         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8191      &    +ekont*derx_turn(ll,4,1)
8192         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8193         ghalf=0.5d0*ggg2(ll)
8194 cd        ghalf=0.0d0
8195         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8196      &    +ekont*derx_turn(ll,2,2)
8197         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8198         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8199      &    +ekont*derx_turn(ll,4,2)
8200         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8201       enddo
8202 cd      goto 1112
8203       do m=i+1,j-1
8204         do ll=1,3
8205           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8206         enddo
8207       enddo
8208       do m=k+1,l-1
8209         do ll=1,3
8210           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8211         enddo
8212       enddo
8213 1112  continue
8214       do m=i+2,j2
8215         do ll=1,3
8216           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8217         enddo
8218       enddo
8219       do m=k+2,l2
8220         do ll=1,3
8221           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8222         enddo
8223       enddo
8224 cd      do iii=1,nres-3
8225 cd        write (2,*) iii,g_corr6_loc(iii)
8226 cd      enddo
8227       endif
8228       eello_turn6=ekont*eel_turn6
8229 cd      write (2,*) 'ekont',ekont
8230 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8231       return
8232       end
8233 crc-------------------------------------------------
8234       SUBROUTINE MATVEC2(A1,V1,V2)
8235       implicit real*8 (a-h,o-z)
8236       include 'DIMENSIONS'
8237       DIMENSION A1(2,2),V1(2),V2(2)
8238 c      DO 1 I=1,2
8239 c        VI=0.0
8240 c        DO 3 K=1,2
8241 c    3     VI=VI+A1(I,K)*V1(K)
8242 c        Vaux(I)=VI
8243 c    1 CONTINUE
8244
8245       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8246       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8247
8248       v2(1)=vaux1
8249       v2(2)=vaux2
8250       END
8251 C---------------------------------------
8252       SUBROUTINE MATMAT2(A1,A2,A3)
8253       implicit real*8 (a-h,o-z)
8254       include 'DIMENSIONS'
8255       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8256 c      DIMENSION AI3(2,2)
8257 c        DO  J=1,2
8258 c          A3IJ=0.0
8259 c          DO K=1,2
8260 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8261 c          enddo
8262 c          A3(I,J)=A3IJ
8263 c       enddo
8264 c      enddo
8265
8266       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8267       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8268       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8269       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8270
8271       A3(1,1)=AI3_11
8272       A3(2,1)=AI3_21
8273       A3(1,2)=AI3_12
8274       A3(2,2)=AI3_22
8275       END
8276
8277 c-------------------------------------------------------------------------
8278       double precision function scalar2(u,v)
8279       implicit none
8280       double precision u(2),v(2)
8281       double precision sc
8282       integer i
8283       scalar2=u(1)*v(1)+u(2)*v(2)
8284       return
8285       end
8286
8287 C-----------------------------------------------------------------------------
8288
8289       subroutine transpose2(a,at)
8290       implicit none
8291       double precision a(2,2),at(2,2)
8292       at(1,1)=a(1,1)
8293       at(1,2)=a(2,1)
8294       at(2,1)=a(1,2)
8295       at(2,2)=a(2,2)
8296       return
8297       end
8298 c--------------------------------------------------------------------------
8299       subroutine transpose(n,a,at)
8300       implicit none
8301       integer n,i,j
8302       double precision a(n,n),at(n,n)
8303       do i=1,n
8304         do j=1,n
8305           at(j,i)=a(i,j)
8306         enddo
8307       enddo
8308       return
8309       end
8310 C---------------------------------------------------------------------------
8311       subroutine prodmat3(a1,a2,kk,transp,prod)
8312       implicit none
8313       integer i,j
8314       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8315       logical transp
8316 crc      double precision auxmat(2,2),prod_(2,2)
8317
8318       if (transp) then
8319 crc        call transpose2(kk(1,1),auxmat(1,1))
8320 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8321 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8322
8323            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8324      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8325            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8326      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8327            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8328      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8329            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8330      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8331
8332       else
8333 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8334 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8335
8336            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8337      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8338            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8339      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8340            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8341      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8342            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8343      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8344
8345       endif
8346 c      call transpose2(a2(1,1),a2t(1,1))
8347
8348 crc      print *,transp
8349 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8350 crc      print *,((prod(i,j),i=1,2),j=1,2)
8351
8352       return
8353       end
8354 C-----------------------------------------------------------------------------
8355       double precision function scalar(u,v)
8356       implicit none
8357       double precision u(3),v(3)
8358       double precision sc
8359       integer i
8360       sc=0.0d0
8361       do i=1,3
8362         sc=sc+u(i)*v(i)
8363       enddo
8364       scalar=sc
8365       return
8366       end
8367 C-----------------------------------------------------------------------
8368       double precision function sscale(r)
8369       double precision r,gamm
8370       include "COMMON.SPLITELE"
8371       if(r.lt.r_cut-rlamb) then
8372         sscale=1.0d0
8373       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8374         gamm=(r-(r_cut-rlamb))/rlamb
8375         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8376       else
8377         sscale=0d0
8378       endif
8379       return
8380       end
8381 C-----------------------------------------------------------------------
8382 C-----------------------------------------------------------------------
8383       double precision function sscagrad(r)
8384       double precision r,gamm
8385       include "COMMON.SPLITELE"
8386       if(r.lt.r_cut-rlamb) then
8387         sscagrad=0.0d0
8388       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8389         gamm=(r-(r_cut-rlamb))/rlamb
8390         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8391       else
8392         sscagrad=0.0d0
8393       endif
8394       return
8395       end
8396 C-----------------------------------------------------------------------
8397 C first for shielding is setting of function of side-chains
8398        subroutine set_shield_fac2
8399       implicit real*8 (a-h,o-z)
8400       include 'DIMENSIONS'
8401       include 'COMMON.CHAIN'
8402       include 'COMMON.DERIV'
8403       include 'COMMON.IOUNITS'
8404       include 'COMMON.SHIELD'
8405       include 'COMMON.INTERACT'
8406 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8407       double precision div77_81/0.974996043d0/,
8408      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8409
8410 C the vector between center of side_chain and peptide group
8411        double precision pep_side(3),long,side_calf(3),
8412      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8413      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8414 C the line belowe needs to be changed for FGPROC>1
8415       do i=1,nres-1
8416       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8417       ishield_list(i)=0
8418 Cif there two consequtive dummy atoms there is no peptide group between them
8419 C the line below has to be changed for FGPROC>1
8420       VolumeTotal=0.0
8421       do k=1,nres
8422        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8423        dist_pep_side=0.0
8424        dist_side_calf=0.0
8425        do j=1,3
8426 C first lets set vector conecting the ithe side-chain with kth side-chain
8427       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8428 C      pep_side(j)=2.0d0
8429 C and vector conecting the side-chain with its proper calfa
8430       side_calf(j)=c(j,k+nres)-c(j,k)
8431 C      side_calf(j)=2.0d0
8432       pept_group(j)=c(j,i)-c(j,i+1)
8433 C lets have their lenght
8434       dist_pep_side=pep_side(j)**2+dist_pep_side
8435       dist_side_calf=dist_side_calf+side_calf(j)**2
8436       dist_pept_group=dist_pept_group+pept_group(j)**2
8437       enddo
8438        dist_pep_side=dsqrt(dist_pep_side)
8439        dist_pept_group=dsqrt(dist_pept_group)
8440        dist_side_calf=dsqrt(dist_side_calf)
8441       do j=1,3
8442         pep_side_norm(j)=pep_side(j)/dist_pep_side
8443         side_calf_norm(j)=dist_side_calf
8444       enddo
8445 C now sscale fraction
8446        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8447 C       print *,buff_shield,"buff"
8448 C now sscale
8449         if (sh_frac_dist.le.0.0) cycle
8450 C If we reach here it means that this side chain reaches the shielding sphere
8451 C Lets add him to the list for gradient
8452         ishield_list(i)=ishield_list(i)+1
8453 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8454 C this list is essential otherwise problem would be O3
8455         shield_list(ishield_list(i),i)=k
8456 C Lets have the sscale value
8457         if (sh_frac_dist.gt.1.0) then
8458          scale_fac_dist=1.0d0
8459          do j=1,3
8460          sh_frac_dist_grad(j)=0.0d0
8461          enddo
8462         else
8463          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8464      &                   *(2.0d0*sh_frac_dist-3.0d0)
8465          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8466      &                  /dist_pep_side/buff_shield*0.5d0
8467 C remember for the final gradient multiply sh_frac_dist_grad(j)
8468 C for side_chain by factor -2 !
8469          do j=1,3
8470          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8471 C         sh_frac_dist_grad(j)=0.0d0
8472 C         scale_fac_dist=1.0d0
8473 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8474 C     &                    sh_frac_dist_grad(j)
8475          enddo
8476         endif
8477 C this is what is now we have the distance scaling now volume...
8478       short=short_r_sidechain(itype(k))
8479       long=long_r_sidechain(itype(k))
8480       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8481       sinthet=short/dist_pep_side*costhet
8482 C now costhet_grad
8483 C       costhet=0.6d0
8484 C       sinthet=0.8
8485        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8486 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8487 C     &             -short/dist_pep_side**2/costhet)
8488 C       costhet_fac=0.0d0
8489        do j=1,3
8490          costhet_grad(j)=costhet_fac*pep_side(j)
8491        enddo
8492 C remember for the final gradient multiply costhet_grad(j)
8493 C for side_chain by factor -2 !
8494 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8495 C pep_side0pept_group is vector multiplication
8496       pep_side0pept_group=0.0d0
8497       do j=1,3
8498       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8499       enddo
8500       cosalfa=(pep_side0pept_group/
8501      & (dist_pep_side*dist_side_calf))
8502       fac_alfa_sin=1.0d0-cosalfa**2
8503       fac_alfa_sin=dsqrt(fac_alfa_sin)
8504       rkprim=fac_alfa_sin*(long-short)+short
8505 C      rkprim=short
8506
8507 C now costhet_grad
8508        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8509 C       cosphi=0.6
8510        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8511        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8512      &      dist_pep_side**2)
8513 C       sinphi=0.8
8514        do j=1,3
8515          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8516      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8517      &*(long-short)/fac_alfa_sin*cosalfa/
8518      &((dist_pep_side*dist_side_calf))*
8519      &((side_calf(j))-cosalfa*
8520      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8521 C       cosphi_grad_long(j)=0.0d0
8522         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8523      &*(long-short)/fac_alfa_sin*cosalfa
8524      &/((dist_pep_side*dist_side_calf))*
8525      &(pep_side(j)-
8526      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8527 C       cosphi_grad_loc(j)=0.0d0
8528        enddo
8529 C      print *,sinphi,sinthet
8530       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8531      &                    /VSolvSphere_div
8532 C     &                    *wshield
8533 C now the gradient...
8534       do j=1,3
8535       grad_shield(j,i)=grad_shield(j,i)
8536 C gradient po skalowaniu
8537      &                +(sh_frac_dist_grad(j)*VofOverlap
8538 C  gradient po costhet
8539      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8540      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8541      &       sinphi/sinthet*costhet*costhet_grad(j)
8542      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8543      & )*wshield
8544 C grad_shield_side is Cbeta sidechain gradient
8545       grad_shield_side(j,ishield_list(i),i)=
8546      &        (sh_frac_dist_grad(j)*-2.0d0
8547      &        *VofOverlap
8548      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8549      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8550      &       sinphi/sinthet*costhet*costhet_grad(j)
8551      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8552      &       )*wshield
8553
8554        grad_shield_loc(j,ishield_list(i),i)=
8555      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8556      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8557      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8558      &        ))
8559      &        *wshield
8560       enddo
8561       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8562       enddo
8563       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8564 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8565       enddo
8566       return
8567       end
8568 C first for shielding is setting of function of side-chains
8569        subroutine set_shield_fac
8570       implicit real*8 (a-h,o-z)
8571       include 'DIMENSIONS'
8572       include 'COMMON.CHAIN'
8573       include 'COMMON.DERIV'
8574       include 'COMMON.IOUNITS'
8575       include 'COMMON.SHIELD'
8576       include 'COMMON.INTERACT'
8577 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8578       double precision div77_81/0.974996043d0/,
8579      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8580
8581 C the vector between center of side_chain and peptide group
8582        double precision pep_side(3),long,side_calf(3),
8583      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8584      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8585 C the line belowe needs to be changed for FGPROC>1
8586       do i=1,nres-1
8587       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8588       ishield_list(i)=0
8589 Cif there two consequtive dummy atoms there is no peptide group between them
8590 C the line below has to be changed for FGPROC>1
8591       VolumeTotal=0.0
8592       do k=1,nres
8593        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8594        dist_pep_side=0.0
8595        dist_side_calf=0.0
8596        do j=1,3
8597 C first lets set vector conecting the ithe side-chain with kth side-chain
8598       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8599 C      pep_side(j)=2.0d0
8600 C and vector conecting the side-chain with its proper calfa
8601       side_calf(j)=c(j,k+nres)-c(j,k)
8602 C      side_calf(j)=2.0d0
8603       pept_group(j)=c(j,i)-c(j,i+1)
8604 C lets have their lenght
8605       dist_pep_side=pep_side(j)**2+dist_pep_side
8606       dist_side_calf=dist_side_calf+side_calf(j)**2
8607       dist_pept_group=dist_pept_group+pept_group(j)**2
8608       enddo
8609        dist_pep_side=dsqrt(dist_pep_side)
8610        dist_pept_group=dsqrt(dist_pept_group)
8611        dist_side_calf=dsqrt(dist_side_calf)
8612       do j=1,3
8613         pep_side_norm(j)=pep_side(j)/dist_pep_side
8614         side_calf_norm(j)=dist_side_calf
8615       enddo
8616 C now sscale fraction
8617        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8618 C       print *,buff_shield,"buff"
8619 C now sscale
8620         if (sh_frac_dist.le.0.0) cycle
8621 C If we reach here it means that this side chain reaches the shielding sphere
8622 C Lets add him to the list for gradient
8623         ishield_list(i)=ishield_list(i)+1
8624 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8625 C this list is essential otherwise problem would be O3
8626         shield_list(ishield_list(i),i)=k
8627 C Lets have the sscale value
8628         if (sh_frac_dist.gt.1.0) then
8629          scale_fac_dist=1.0d0
8630          do j=1,3
8631          sh_frac_dist_grad(j)=0.0d0
8632          enddo
8633         else
8634          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8635      &                   *(2.0*sh_frac_dist-3.0d0)
8636          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8637      &                  /dist_pep_side/buff_shield*0.5
8638 C remember for the final gradient multiply sh_frac_dist_grad(j)
8639 C for side_chain by factor -2 !
8640          do j=1,3
8641          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8642 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8643 C     &                    sh_frac_dist_grad(j)
8644          enddo
8645         endif
8646 C        if ((i.eq.3).and.(k.eq.2)) then
8647 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8648 C     & ,"TU"
8649 C        endif
8650
8651 C this is what is now we have the distance scaling now volume...
8652       short=short_r_sidechain(itype(k))
8653       long=long_r_sidechain(itype(k))
8654       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8655 C now costhet_grad
8656 C       costhet=0.0d0
8657        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8658 C       costhet_fac=0.0d0
8659        do j=1,3
8660          costhet_grad(j)=costhet_fac*pep_side(j)
8661        enddo
8662 C remember for the final gradient multiply costhet_grad(j)
8663 C for side_chain by factor -2 !
8664 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8665 C pep_side0pept_group is vector multiplication
8666       pep_side0pept_group=0.0
8667       do j=1,3
8668       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8669       enddo
8670       cosalfa=(pep_side0pept_group/
8671      & (dist_pep_side*dist_side_calf))
8672       fac_alfa_sin=1.0-cosalfa**2
8673       fac_alfa_sin=dsqrt(fac_alfa_sin)
8674       rkprim=fac_alfa_sin*(long-short)+short
8675 C now costhet_grad
8676        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8677        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8678
8679        do j=1,3
8680          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8681      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8682      &*(long-short)/fac_alfa_sin*cosalfa/
8683      &((dist_pep_side*dist_side_calf))*
8684      &((side_calf(j))-cosalfa*
8685      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8686
8687         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8688      &*(long-short)/fac_alfa_sin*cosalfa
8689      &/((dist_pep_side*dist_side_calf))*
8690      &(pep_side(j)-
8691      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8692        enddo
8693
8694       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8695      &                    /VSolvSphere_div
8696      &                    *wshield
8697 C now the gradient...
8698 C grad_shield is gradient of Calfa for peptide groups
8699 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8700 C     &               costhet,cosphi
8701 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8702 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8703       do j=1,3
8704       grad_shield(j,i)=grad_shield(j,i)
8705 C gradient po skalowaniu
8706      &                +(sh_frac_dist_grad(j)
8707 C  gradient po costhet
8708      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8709      &-scale_fac_dist*(cosphi_grad_long(j))
8710      &/(1.0-cosphi) )*div77_81
8711      &*VofOverlap
8712 C grad_shield_side is Cbeta sidechain gradient
8713       grad_shield_side(j,ishield_list(i),i)=
8714      &        (sh_frac_dist_grad(j)*-2.0d0
8715      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8716      &       +scale_fac_dist*(cosphi_grad_long(j))
8717      &        *2.0d0/(1.0-cosphi))
8718      &        *div77_81*VofOverlap
8719
8720        grad_shield_loc(j,ishield_list(i),i)=
8721      &   scale_fac_dist*cosphi_grad_loc(j)
8722      &        *2.0d0/(1.0-cosphi)
8723      &        *div77_81*VofOverlap
8724       enddo
8725       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8726       enddo
8727       fac_shield(i)=VolumeTotal*div77_81+div4_81
8728 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8729       enddo
8730       return
8731       end
8732 C--------------------------------------------------------------------------
8733