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 C      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 C      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 /.false./
 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 #ifdef DEBUG
1050             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1051      &        restyp(itypi),i,restyp(itypj),j,
1052      &        epsi,sigm,chi1,chi2,chip1,chip2,
1053      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1054      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1055      &        evdwij
1056              write (iout,*) "pratial sum", evdw,evdw_t
1057 #endif
1058 c            endif
1059             if (calc_grad) then
1060 C Calculate gradient components.
1061             e1=e1*eps1*eps2rt**2*eps3rt**2
1062             fac=-expon*(e1+evdwij)*rij_shift
1063             sigder=fac*sigder
1064             fac=rij*fac
1065             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1066 C Calculate the radial part of the gradient
1067             gg(1)=xj*fac
1068             gg(2)=yj*fac
1069             gg(3)=zj*fac
1070 C Calculate angular part of the gradient.
1071             call sc_grad
1072             endif
1073             ENDIF    ! dyn_ss
1074           enddo      ! j
1075         enddo        ! iint
1076       enddo          ! i
1077       return
1078       end
1079 C-----------------------------------------------------------------------------
1080       subroutine egbv(evdw,evdw_t)
1081 C
1082 C This subroutine calculates the interaction energy of nonbonded side chains
1083 C assuming the Gay-Berne-Vorobjev potential of interaction.
1084 C
1085       implicit real*8 (a-h,o-z)
1086       include 'DIMENSIONS'
1087       include 'sizesclu.dat'
1088       include "DIMENSIONS.COMPAR"
1089       include 'COMMON.GEO'
1090       include 'COMMON.VAR'
1091       include 'COMMON.LOCAL'
1092       include 'COMMON.CHAIN'
1093       include 'COMMON.DERIV'
1094       include 'COMMON.NAMES'
1095       include 'COMMON.INTERACT'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.CALC'
1098       common /srutu/ icall
1099       logical lprn
1100       integer icant
1101       external icant
1102       evdw=0.0D0
1103       evdw_t=0.0d0
1104 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1105       evdw=0.0D0
1106       lprn=.false.
1107 c      if (icall.gt.0) lprn=.true.
1108       ind=0
1109       do i=iatsc_s,iatsc_e
1110         itypi=iabs(itype(i))
1111         if (itypi.eq.ntyp1) cycle
1112         itypi1=iabs(itype(i+1))
1113         xi=c(1,nres+i)
1114         yi=c(2,nres+i)
1115         zi=c(3,nres+i)
1116         dxi=dc_norm(1,nres+i)
1117         dyi=dc_norm(2,nres+i)
1118         dzi=dc_norm(3,nres+i)
1119         dsci_inv=vbld_inv(i+nres)
1120 C
1121 C Calculate SC interaction energy.
1122 C
1123         do iint=1,nint_gr(i)
1124           do j=istart(i,iint),iend(i,iint)
1125             ind=ind+1
1126             itypj=iabs(itype(j))
1127             if (itypj.eq.ntyp1) cycle
1128             dscj_inv=vbld_inv(j+nres)
1129             sig0ij=sigma(itypi,itypj)
1130             r0ij=r0(itypi,itypj)
1131             chi1=chi(itypi,itypj)
1132             chi2=chi(itypj,itypi)
1133             chi12=chi1*chi2
1134             chip1=chip(itypi)
1135             chip2=chip(itypj)
1136             chip12=chip1*chip2
1137             alf1=alp(itypi)
1138             alf2=alp(itypj)
1139             alf12=0.5D0*(alf1+alf2)
1140 C For diagnostics only!!!
1141 c           chi1=0.0D0
1142 c           chi2=0.0D0
1143 c           chi12=0.0D0
1144 c           chip1=0.0D0
1145 c           chip2=0.0D0
1146 c           chip12=0.0D0
1147 c           alf1=0.0D0
1148 c           alf2=0.0D0
1149 c           alf12=0.0D0
1150             xj=c(1,nres+j)-xi
1151             yj=c(2,nres+j)-yi
1152             zj=c(3,nres+j)-zi
1153             dxj=dc_norm(1,nres+j)
1154             dyj=dc_norm(2,nres+j)
1155             dzj=dc_norm(3,nres+j)
1156             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1157             rij=dsqrt(rrij)
1158 C Calculate angle-dependent terms of energy and contributions to their
1159 C derivatives.
1160             call sc_angular
1161             sigsq=1.0D0/sigsq
1162             sig=sig0ij*dsqrt(sigsq)
1163             rij_shift=1.0D0/rij-sig+r0ij
1164 C I hate to put IF's in the loops, but here don't have another choice!!!!
1165             if (rij_shift.le.0.0D0) then
1166               evdw=1.0D20
1167               return
1168             endif
1169             sigder=-sig*sigsq
1170 c---------------------------------------------------------------
1171             rij_shift=1.0D0/rij_shift
1172             fac=rij_shift**expon
1173             e1=fac*fac*aa(itypi,itypj)
1174             e2=fac*bb(itypi,itypj)
1175             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1176             eps2der=evdwij*eps3rt
1177             eps3der=evdwij*eps2rt
1178             fac_augm=rrij**expon
1179             e_augm=augm(itypi,itypj)*fac_augm
1180             evdwij=evdwij*eps2rt*eps3rt
1181             if (bb(itypi,itypj).gt.0.0d0) then
1182               evdw=evdw+evdwij+e_augm
1183             else
1184               evdw_t=evdw_t+evdwij+e_augm
1185             endif
1186             ij=icant(itypi,itypj)
1187             aux=eps1*eps2rt**2*eps3rt**2
1188 c            if (lprn) then
1189 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1190 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1191 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1192 c     &        restyp(itypi),i,restyp(itypj),j,
1193 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1194 c     &        chi1,chi2,chip1,chip2,
1195 c     &        eps1,eps2rt**2,eps3rt**2,
1196 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1197 c     &        evdwij+e_augm
1198 c            endif
1199             if (calc_grad) then
1200 C Calculate gradient components.
1201             e1=e1*eps1*eps2rt**2*eps3rt**2
1202             fac=-expon*(e1+evdwij)*rij_shift
1203             sigder=fac*sigder
1204             fac=rij*fac-2*expon*rrij*e_augm
1205 C Calculate the radial part of the gradient
1206             gg(1)=xj*fac
1207             gg(2)=yj*fac
1208             gg(3)=zj*fac
1209 C Calculate angular part of the gradient.
1210             call sc_grad
1211             endif
1212           enddo      ! j
1213         enddo        ! iint
1214       enddo          ! i
1215       return
1216       end
1217 C-----------------------------------------------------------------------------
1218       subroutine sc_angular
1219 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1220 C om12. Called by ebp, egb, and egbv.
1221       implicit none
1222       include 'COMMON.CALC'
1223       erij(1)=xj*rij
1224       erij(2)=yj*rij
1225       erij(3)=zj*rij
1226       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1227       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1228       om12=dxi*dxj+dyi*dyj+dzi*dzj
1229       chiom12=chi12*om12
1230 C Calculate eps1(om12) and its derivative in om12
1231       faceps1=1.0D0-om12*chiom12
1232       faceps1_inv=1.0D0/faceps1
1233       eps1=dsqrt(faceps1_inv)
1234 C Following variable is eps1*deps1/dom12
1235       eps1_om12=faceps1_inv*chiom12
1236 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1237 C and om12.
1238       om1om2=om1*om2
1239       chiom1=chi1*om1
1240       chiom2=chi2*om2
1241       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1242       sigsq=1.0D0-facsig*faceps1_inv
1243       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1244       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1245       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1246 C Calculate eps2 and its derivatives in om1, om2, and om12.
1247       chipom1=chip1*om1
1248       chipom2=chip2*om2
1249       chipom12=chip12*om12
1250       facp=1.0D0-om12*chipom12
1251       facp_inv=1.0D0/facp
1252       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1253 C Following variable is the square root of eps2
1254       eps2rt=1.0D0-facp1*facp_inv
1255 C Following three variables are the derivatives of the square root of eps
1256 C in om1, om2, and om12.
1257       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1258       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1259       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1260 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1261       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1262 C Calculate whole angle-dependent part of epsilon and contributions
1263 C to its derivatives
1264       return
1265       end
1266 C----------------------------------------------------------------------------
1267       subroutine sc_grad
1268       implicit real*8 (a-h,o-z)
1269       include 'DIMENSIONS'
1270       include 'sizesclu.dat'
1271       include 'COMMON.CHAIN'
1272       include 'COMMON.DERIV'
1273       include 'COMMON.CALC'
1274       double precision dcosom1(3),dcosom2(3)
1275       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1276       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1277       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1278      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1279       do k=1,3
1280         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1281         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1282       enddo
1283       do k=1,3
1284         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1285       enddo
1286       do k=1,3
1287         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1288      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1289      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1290         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1291      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1292      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1293       enddo
1294 C
1295 C Calculate the components of the gradient in DC and X
1296 C
1297       do k=i,j-1
1298         do l=1,3
1299           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1300         enddo
1301       enddo
1302       return
1303       end
1304 c------------------------------------------------------------------------------
1305       subroutine vec_and_deriv
1306       implicit real*8 (a-h,o-z)
1307       include 'DIMENSIONS'
1308       include 'sizesclu.dat'
1309       include 'COMMON.IOUNITS'
1310       include 'COMMON.GEO'
1311       include 'COMMON.VAR'
1312       include 'COMMON.LOCAL'
1313       include 'COMMON.CHAIN'
1314       include 'COMMON.VECTORS'
1315       include 'COMMON.DERIV'
1316       include 'COMMON.INTERACT'
1317       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1318 C Compute the local reference systems. For reference system (i), the
1319 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1320 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1321       do i=1,nres-1
1322 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1323           if (i.eq.nres-1) then
1324 C Case of the last full residue
1325 C Compute the Z-axis
1326             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1327             costh=dcos(pi-theta(nres))
1328             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1329             do k=1,3
1330               uz(k,i)=fac*uz(k,i)
1331             enddo
1332             if (calc_grad) then
1333 C Compute the derivatives of uz
1334             uzder(1,1,1)= 0.0d0
1335             uzder(2,1,1)=-dc_norm(3,i-1)
1336             uzder(3,1,1)= dc_norm(2,i-1)
1337             uzder(1,2,1)= dc_norm(3,i-1)
1338             uzder(2,2,1)= 0.0d0
1339             uzder(3,2,1)=-dc_norm(1,i-1)
1340             uzder(1,3,1)=-dc_norm(2,i-1)
1341             uzder(2,3,1)= dc_norm(1,i-1)
1342             uzder(3,3,1)= 0.0d0
1343             uzder(1,1,2)= 0.0d0
1344             uzder(2,1,2)= dc_norm(3,i)
1345             uzder(3,1,2)=-dc_norm(2,i)
1346             uzder(1,2,2)=-dc_norm(3,i)
1347             uzder(2,2,2)= 0.0d0
1348             uzder(3,2,2)= dc_norm(1,i)
1349             uzder(1,3,2)= dc_norm(2,i)
1350             uzder(2,3,2)=-dc_norm(1,i)
1351             uzder(3,3,2)= 0.0d0
1352             endif
1353 C Compute the Y-axis
1354             facy=fac
1355             do k=1,3
1356               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1357             enddo
1358             if (calc_grad) then
1359 C Compute the derivatives of uy
1360             do j=1,3
1361               do k=1,3
1362                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1363      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1364                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1365               enddo
1366               uyder(j,j,1)=uyder(j,j,1)-costh
1367               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1368             enddo
1369             do j=1,2
1370               do k=1,3
1371                 do l=1,3
1372                   uygrad(l,k,j,i)=uyder(l,k,j)
1373                   uzgrad(l,k,j,i)=uzder(l,k,j)
1374                 enddo
1375               enddo
1376             enddo
1377             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1378             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1379             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1380             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1381             endif
1382           else
1383 C Other residues
1384 C Compute the Z-axis
1385             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1386             costh=dcos(pi-theta(i+2))
1387             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1388             do k=1,3
1389               uz(k,i)=fac*uz(k,i)
1390             enddo
1391             if (calc_grad) then
1392 C Compute the derivatives of uz
1393             uzder(1,1,1)= 0.0d0
1394             uzder(2,1,1)=-dc_norm(3,i+1)
1395             uzder(3,1,1)= dc_norm(2,i+1)
1396             uzder(1,2,1)= dc_norm(3,i+1)
1397             uzder(2,2,1)= 0.0d0
1398             uzder(3,2,1)=-dc_norm(1,i+1)
1399             uzder(1,3,1)=-dc_norm(2,i+1)
1400             uzder(2,3,1)= dc_norm(1,i+1)
1401             uzder(3,3,1)= 0.0d0
1402             uzder(1,1,2)= 0.0d0
1403             uzder(2,1,2)= dc_norm(3,i)
1404             uzder(3,1,2)=-dc_norm(2,i)
1405             uzder(1,2,2)=-dc_norm(3,i)
1406             uzder(2,2,2)= 0.0d0
1407             uzder(3,2,2)= dc_norm(1,i)
1408             uzder(1,3,2)= dc_norm(2,i)
1409             uzder(2,3,2)=-dc_norm(1,i)
1410             uzder(3,3,2)= 0.0d0
1411             endif
1412 C Compute the Y-axis
1413             facy=fac
1414             do k=1,3
1415               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1416             enddo
1417             if (calc_grad) then
1418 C Compute the derivatives of uy
1419             do j=1,3
1420               do k=1,3
1421                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1422      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1423                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1424               enddo
1425               uyder(j,j,1)=uyder(j,j,1)-costh
1426               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1427             enddo
1428             do j=1,2
1429               do k=1,3
1430                 do l=1,3
1431                   uygrad(l,k,j,i)=uyder(l,k,j)
1432                   uzgrad(l,k,j,i)=uzder(l,k,j)
1433                 enddo
1434               enddo
1435             enddo
1436             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1437             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1438             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1439             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1440           endif
1441           endif
1442       enddo
1443       if (calc_grad) then
1444       do i=1,nres-1
1445         vbld_inv_temp(1)=vbld_inv(i+1)
1446         if (i.lt.nres-1) then
1447           vbld_inv_temp(2)=vbld_inv(i+2)
1448         else
1449           vbld_inv_temp(2)=vbld_inv(i)
1450         endif
1451         do j=1,2
1452           do k=1,3
1453             do l=1,3
1454               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1455               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1456             enddo
1457           enddo
1458         enddo
1459       enddo
1460       endif
1461       return
1462       end
1463 C-----------------------------------------------------------------------------
1464       subroutine vec_and_deriv_test
1465       implicit real*8 (a-h,o-z)
1466       include 'DIMENSIONS'
1467       include 'sizesclu.dat'
1468       include 'COMMON.IOUNITS'
1469       include 'COMMON.GEO'
1470       include 'COMMON.VAR'
1471       include 'COMMON.LOCAL'
1472       include 'COMMON.CHAIN'
1473       include 'COMMON.VECTORS'
1474       dimension uyder(3,3,2),uzder(3,3,2)
1475 C Compute the local reference systems. For reference system (i), the
1476 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1477 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1478       do i=1,nres-1
1479           if (i.eq.nres-1) then
1480 C Case of the last full residue
1481 C Compute the Z-axis
1482             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1483             costh=dcos(pi-theta(nres))
1484             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1485 c            write (iout,*) 'fac',fac,
1486 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1487             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1488             do k=1,3
1489               uz(k,i)=fac*uz(k,i)
1490             enddo
1491 C Compute the derivatives of uz
1492             uzder(1,1,1)= 0.0d0
1493             uzder(2,1,1)=-dc_norm(3,i-1)
1494             uzder(3,1,1)= dc_norm(2,i-1)
1495             uzder(1,2,1)= dc_norm(3,i-1)
1496             uzder(2,2,1)= 0.0d0
1497             uzder(3,2,1)=-dc_norm(1,i-1)
1498             uzder(1,3,1)=-dc_norm(2,i-1)
1499             uzder(2,3,1)= dc_norm(1,i-1)
1500             uzder(3,3,1)= 0.0d0
1501             uzder(1,1,2)= 0.0d0
1502             uzder(2,1,2)= dc_norm(3,i)
1503             uzder(3,1,2)=-dc_norm(2,i)
1504             uzder(1,2,2)=-dc_norm(3,i)
1505             uzder(2,2,2)= 0.0d0
1506             uzder(3,2,2)= dc_norm(1,i)
1507             uzder(1,3,2)= dc_norm(2,i)
1508             uzder(2,3,2)=-dc_norm(1,i)
1509             uzder(3,3,2)= 0.0d0
1510 C Compute the Y-axis
1511             do k=1,3
1512               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1513             enddo
1514             facy=fac
1515             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1516      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1517      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1518             do k=1,3
1519 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1520               uy(k,i)=
1521 c     &        facy*(
1522      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1523      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1524 c     &        )
1525             enddo
1526 c            write (iout,*) 'facy',facy,
1527 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1528             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1529             do k=1,3
1530               uy(k,i)=facy*uy(k,i)
1531             enddo
1532 C Compute the derivatives of uy
1533             do j=1,3
1534               do k=1,3
1535                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1536      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1537                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1538               enddo
1539 c              uyder(j,j,1)=uyder(j,j,1)-costh
1540 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1541               uyder(j,j,1)=uyder(j,j,1)
1542      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1543               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1544      &          +uyder(j,j,2)
1545             enddo
1546             do j=1,2
1547               do k=1,3
1548                 do l=1,3
1549                   uygrad(l,k,j,i)=uyder(l,k,j)
1550                   uzgrad(l,k,j,i)=uzder(l,k,j)
1551                 enddo
1552               enddo
1553             enddo
1554             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1555             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1556             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1557             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1558           else
1559 C Other residues
1560 C Compute the Z-axis
1561             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1562             costh=dcos(pi-theta(i+2))
1563             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1564             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1565             do k=1,3
1566               uz(k,i)=fac*uz(k,i)
1567             enddo
1568 C Compute the derivatives of uz
1569             uzder(1,1,1)= 0.0d0
1570             uzder(2,1,1)=-dc_norm(3,i+1)
1571             uzder(3,1,1)= dc_norm(2,i+1)
1572             uzder(1,2,1)= dc_norm(3,i+1)
1573             uzder(2,2,1)= 0.0d0
1574             uzder(3,2,1)=-dc_norm(1,i+1)
1575             uzder(1,3,1)=-dc_norm(2,i+1)
1576             uzder(2,3,1)= dc_norm(1,i+1)
1577             uzder(3,3,1)= 0.0d0
1578             uzder(1,1,2)= 0.0d0
1579             uzder(2,1,2)= dc_norm(3,i)
1580             uzder(3,1,2)=-dc_norm(2,i)
1581             uzder(1,2,2)=-dc_norm(3,i)
1582             uzder(2,2,2)= 0.0d0
1583             uzder(3,2,2)= dc_norm(1,i)
1584             uzder(1,3,2)= dc_norm(2,i)
1585             uzder(2,3,2)=-dc_norm(1,i)
1586             uzder(3,3,2)= 0.0d0
1587 C Compute the Y-axis
1588             facy=fac
1589             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1590      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1591      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1592             do k=1,3
1593 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1594               uy(k,i)=
1595 c     &        facy*(
1596      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1597      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1598 c     &        )
1599             enddo
1600 c            write (iout,*) 'facy',facy,
1601 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1602             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1603             do k=1,3
1604               uy(k,i)=facy*uy(k,i)
1605             enddo
1606 C Compute the derivatives of uy
1607             do j=1,3
1608               do k=1,3
1609                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1610      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1611                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1612               enddo
1613 c              uyder(j,j,1)=uyder(j,j,1)-costh
1614 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1615               uyder(j,j,1)=uyder(j,j,1)
1616      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1617               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1618      &          +uyder(j,j,2)
1619             enddo
1620             do j=1,2
1621               do k=1,3
1622                 do l=1,3
1623                   uygrad(l,k,j,i)=uyder(l,k,j)
1624                   uzgrad(l,k,j,i)=uzder(l,k,j)
1625                 enddo
1626               enddo
1627             enddo
1628             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1629             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1630             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1631             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1632           endif
1633       enddo
1634       do i=1,nres-1
1635         do j=1,2
1636           do k=1,3
1637             do l=1,3
1638               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1639               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1640             enddo
1641           enddo
1642         enddo
1643       enddo
1644       return
1645       end
1646 C-----------------------------------------------------------------------------
1647       subroutine check_vecgrad
1648       implicit real*8 (a-h,o-z)
1649       include 'DIMENSIONS'
1650       include 'sizesclu.dat'
1651       include 'COMMON.IOUNITS'
1652       include 'COMMON.GEO'
1653       include 'COMMON.VAR'
1654       include 'COMMON.LOCAL'
1655       include 'COMMON.CHAIN'
1656       include 'COMMON.VECTORS'
1657       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1658       dimension uyt(3,maxres),uzt(3,maxres)
1659       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1660       double precision delta /1.0d-7/
1661       call vec_and_deriv
1662 cd      do i=1,nres
1663 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1664 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1665 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1666 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1667 cd     &     (dc_norm(if90,i),if90=1,3)
1668 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1669 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1670 cd          write(iout,'(a)')
1671 cd      enddo
1672       do i=1,nres
1673         do j=1,2
1674           do k=1,3
1675             do l=1,3
1676               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1677               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1678             enddo
1679           enddo
1680         enddo
1681       enddo
1682       call vec_and_deriv
1683       do i=1,nres
1684         do j=1,3
1685           uyt(j,i)=uy(j,i)
1686           uzt(j,i)=uz(j,i)
1687         enddo
1688       enddo
1689       do i=1,nres
1690 cd        write (iout,*) 'i=',i
1691         do k=1,3
1692           erij(k)=dc_norm(k,i)
1693         enddo
1694         do j=1,3
1695           do k=1,3
1696             dc_norm(k,i)=erij(k)
1697           enddo
1698           dc_norm(j,i)=dc_norm(j,i)+delta
1699 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1700 c          do k=1,3
1701 c            dc_norm(k,i)=dc_norm(k,i)/fac
1702 c          enddo
1703 c          write (iout,*) (dc_norm(k,i),k=1,3)
1704 c          write (iout,*) (erij(k),k=1,3)
1705           call vec_and_deriv
1706           do k=1,3
1707             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1708             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1709             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1710             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1711           enddo
1712 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1713 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1714 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1715         enddo
1716         do k=1,3
1717           dc_norm(k,i)=erij(k)
1718         enddo
1719 cd        do k=1,3
1720 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1721 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1722 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1723 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1724 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1725 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1726 cd          write (iout,'(a)')
1727 cd        enddo
1728       enddo
1729       return
1730       end
1731 C--------------------------------------------------------------------------
1732       subroutine set_matrices
1733       implicit real*8 (a-h,o-z)
1734       include 'DIMENSIONS'
1735       include 'sizesclu.dat'
1736       include 'COMMON.IOUNITS'
1737       include 'COMMON.GEO'
1738       include 'COMMON.VAR'
1739       include 'COMMON.LOCAL'
1740       include 'COMMON.CHAIN'
1741       include 'COMMON.DERIV'
1742       include 'COMMON.INTERACT'
1743       include 'COMMON.CONTACTS'
1744       include 'COMMON.TORSION'
1745       include 'COMMON.VECTORS'
1746       include 'COMMON.FFIELD'
1747       double precision auxvec(2),auxmat(2,2)
1748 C
1749 C Compute the virtual-bond-torsional-angle dependent quantities needed
1750 C to calculate the el-loc multibody terms of various order.
1751 C
1752       do i=3,nres+1
1753         if (i .lt. nres+1) then
1754           sin1=dsin(phi(i))
1755           cos1=dcos(phi(i))
1756           sintab(i-2)=sin1
1757           costab(i-2)=cos1
1758           obrot(1,i-2)=cos1
1759           obrot(2,i-2)=sin1
1760           sin2=dsin(2*phi(i))
1761           cos2=dcos(2*phi(i))
1762           sintab2(i-2)=sin2
1763           costab2(i-2)=cos2
1764           obrot2(1,i-2)=cos2
1765           obrot2(2,i-2)=sin2
1766           Ug(1,1,i-2)=-cos1
1767           Ug(1,2,i-2)=-sin1
1768           Ug(2,1,i-2)=-sin1
1769           Ug(2,2,i-2)= cos1
1770           Ug2(1,1,i-2)=-cos2
1771           Ug2(1,2,i-2)=-sin2
1772           Ug2(2,1,i-2)=-sin2
1773           Ug2(2,2,i-2)= cos2
1774         else
1775           costab(i-2)=1.0d0
1776           sintab(i-2)=0.0d0
1777           obrot(1,i-2)=1.0d0
1778           obrot(2,i-2)=0.0d0
1779           obrot2(1,i-2)=0.0d0
1780           obrot2(2,i-2)=0.0d0
1781           Ug(1,1,i-2)=1.0d0
1782           Ug(1,2,i-2)=0.0d0
1783           Ug(2,1,i-2)=0.0d0
1784           Ug(2,2,i-2)=1.0d0
1785           Ug2(1,1,i-2)=0.0d0
1786           Ug2(1,2,i-2)=0.0d0
1787           Ug2(2,1,i-2)=0.0d0
1788           Ug2(2,2,i-2)=0.0d0
1789         endif
1790         if (i .gt. 3 .and. i .lt. nres+1) then
1791           obrot_der(1,i-2)=-sin1
1792           obrot_der(2,i-2)= cos1
1793           Ugder(1,1,i-2)= sin1
1794           Ugder(1,2,i-2)=-cos1
1795           Ugder(2,1,i-2)=-cos1
1796           Ugder(2,2,i-2)=-sin1
1797           dwacos2=cos2+cos2
1798           dwasin2=sin2+sin2
1799           obrot2_der(1,i-2)=-dwasin2
1800           obrot2_der(2,i-2)= dwacos2
1801           Ug2der(1,1,i-2)= dwasin2
1802           Ug2der(1,2,i-2)=-dwacos2
1803           Ug2der(2,1,i-2)=-dwacos2
1804           Ug2der(2,2,i-2)=-dwasin2
1805         else
1806           obrot_der(1,i-2)=0.0d0
1807           obrot_der(2,i-2)=0.0d0
1808           Ugder(1,1,i-2)=0.0d0
1809           Ugder(1,2,i-2)=0.0d0
1810           Ugder(2,1,i-2)=0.0d0
1811           Ugder(2,2,i-2)=0.0d0
1812           obrot2_der(1,i-2)=0.0d0
1813           obrot2_der(2,i-2)=0.0d0
1814           Ug2der(1,1,i-2)=0.0d0
1815           Ug2der(1,2,i-2)=0.0d0
1816           Ug2der(2,1,i-2)=0.0d0
1817           Ug2der(2,2,i-2)=0.0d0
1818         endif
1819         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1820           if (itype(i-2).le.ntyp) then
1821             iti = itortyp(itype(i-2))
1822           else
1823             iti=ntortyp+1
1824           endif
1825         else
1826           iti=ntortyp+1
1827         endif
1828         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1829           if (itype(i-1).le.ntyp) then
1830             iti1 = itortyp(itype(i-1))
1831           else
1832             iti1=ntortyp+1
1833           endif
1834         else
1835           iti1=ntortyp+1
1836         endif
1837 cd        write (iout,*) '*******i',i,' iti1',iti
1838 cd        write (iout,*) 'b1',b1(:,iti)
1839 cd        write (iout,*) 'b2',b2(:,iti)
1840 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1841 c        print *,"itilde1 i iti iti1",i,iti,iti1
1842         if (i .gt. iatel_s+2) then
1843           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1844           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1845           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1846           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1847           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1848           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1849           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1850         else
1851           do k=1,2
1852             Ub2(k,i-2)=0.0d0
1853             Ctobr(k,i-2)=0.0d0
1854             Dtobr2(k,i-2)=0.0d0
1855             do l=1,2
1856               EUg(l,k,i-2)=0.0d0
1857               CUg(l,k,i-2)=0.0d0
1858               DUg(l,k,i-2)=0.0d0
1859               DtUg2(l,k,i-2)=0.0d0
1860             enddo
1861           enddo
1862         endif
1863 c        print *,"itilde2 i iti iti1",i,iti,iti1
1864         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1865         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1866         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1867         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1868         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1869         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1870         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1871 c        print *,"itilde3 i iti iti1",i,iti,iti1
1872         do k=1,2
1873           muder(k,i-2)=Ub2der(k,i-2)
1874         enddo
1875         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1876           if (itype(i-1).le.ntyp) then
1877             iti1 = itortyp(itype(i-1))
1878           else
1879             iti1=ntortyp+1
1880           endif
1881         else
1882           iti1=ntortyp+1
1883         endif
1884         do k=1,2
1885           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1886         enddo
1887 C Vectors and matrices dependent on a single virtual-bond dihedral.
1888         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1889         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1890         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1891         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1892         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1893         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1894         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1895         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1896         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1897 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1898 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1899       enddo
1900 C Matrices dependent on two consecutive virtual-bond dihedrals.
1901 C The order of matrices is from left to right.
1902       do i=2,nres-1
1903         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1904         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1905         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1906         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1907         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1908         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1909         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1910         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1911       enddo
1912 cd      do i=1,nres
1913 cd        iti = itortyp(itype(i))
1914 cd        write (iout,*) i
1915 cd        do j=1,2
1916 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1917 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1918 cd        enddo
1919 cd      enddo
1920       return
1921       end
1922 C--------------------------------------------------------------------------
1923       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1924 C
1925 C This subroutine calculates the average interaction energy and its gradient
1926 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1927 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1928 C The potential depends both on the distance of peptide-group centers and on
1929 C the orientation of the CA-CA virtual bonds.
1930 C
1931       implicit real*8 (a-h,o-z)
1932       include 'DIMENSIONS'
1933       include 'sizesclu.dat'
1934       include 'COMMON.CONTROL'
1935       include 'COMMON.IOUNITS'
1936       include 'COMMON.GEO'
1937       include 'COMMON.VAR'
1938       include 'COMMON.LOCAL'
1939       include 'COMMON.CHAIN'
1940       include 'COMMON.DERIV'
1941       include 'COMMON.INTERACT'
1942       include 'COMMON.CONTACTS'
1943       include 'COMMON.TORSION'
1944       include 'COMMON.VECTORS'
1945       include 'COMMON.FFIELD'
1946       include 'COMMON.SHIELD'
1947
1948       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1949      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1950       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1951      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1952       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1953 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1954       double precision scal_el /0.5d0/
1955 C 12/13/98
1956 C 13-go grudnia roku pamietnego...
1957       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1958      &                   0.0d0,1.0d0,0.0d0,
1959      &                   0.0d0,0.0d0,1.0d0/
1960 cd      write(iout,*) 'In EELEC'
1961 cd      do i=1,nloctyp
1962 cd        write(iout,*) 'Type',i
1963 cd        write(iout,*) 'B1',B1(:,i)
1964 cd        write(iout,*) 'B2',B2(:,i)
1965 cd        write(iout,*) 'CC',CC(:,:,i)
1966 cd        write(iout,*) 'DD',DD(:,:,i)
1967 cd        write(iout,*) 'EE',EE(:,:,i)
1968 cd      enddo
1969 cd      call check_vecgrad
1970 cd      stop
1971       if (icheckgrad.eq.1) then
1972         do i=1,nres-1
1973           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1974           do k=1,3
1975             dc_norm(k,i)=dc(k,i)*fac
1976           enddo
1977 c          write (iout,*) 'i',i,' fac',fac
1978         enddo
1979       endif
1980       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1981      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1982      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1983 cd      if (wel_loc.gt.0.0d0) then
1984         if (icheckgrad.eq.1) then
1985         call vec_and_deriv_test
1986         else
1987         call vec_and_deriv
1988         endif
1989         call set_matrices
1990       endif
1991 cd      do i=1,nres-1
1992 cd        write (iout,*) 'i=',i
1993 cd        do k=1,3
1994 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1995 cd        enddo
1996 cd        do k=1,3
1997 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1998 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1999 cd        enddo
2000 cd      enddo
2001       num_conti_hb=0
2002       ees=0.0D0
2003       evdw1=0.0D0
2004       eel_loc=0.0d0
2005       eello_turn3=0.0d0
2006       eello_turn4=0.0d0
2007       ind=0
2008       do i=1,nres
2009         num_cont_hb(i)=0
2010       enddo
2011 cd      print '(a)','Enter EELEC'
2012 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2013       do i=1,nres
2014         gel_loc_loc(i)=0.0d0
2015         gcorr_loc(i)=0.0d0
2016       enddo
2017       do i=iatel_s,iatel_e
2018 C          if (i.eq.1) then
2019            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2020 C     &  .or. itype(i+2).eq.ntyp1) cycle
2021 C          else
2022 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2023 C     &  .or. itype(i+2).eq.ntyp1
2024 C     &  .or. itype(i-1).eq.ntyp1
2025      &) cycle
2026 C         endif
2027         if (itel(i).eq.0) goto 1215
2028         dxi=dc(1,i)
2029         dyi=dc(2,i)
2030         dzi=dc(3,i)
2031         dx_normi=dc_norm(1,i)
2032         dy_normi=dc_norm(2,i)
2033         dz_normi=dc_norm(3,i)
2034         xmedi=c(1,i)+0.5d0*dxi
2035         ymedi=c(2,i)+0.5d0*dyi
2036         zmedi=c(3,i)+0.5d0*dzi
2037           xmedi=mod(xmedi,boxxsize)
2038           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2039           ymedi=mod(ymedi,boxysize)
2040           if (ymedi.lt.0) ymedi=ymedi+boxysize
2041           zmedi=mod(zmedi,boxzsize)
2042           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2043         num_conti=0
2044 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2045         do j=ielstart(i),ielend(i)
2046           if (j.le.1) cycle
2047 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2048 C     & .or.itype(j+2).eq.ntyp1
2049 C     &) cycle
2050 C          else
2051           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2052 C     & .or.itype(j+2).eq.ntyp1
2053 C     & .or.itype(j-1).eq.ntyp1
2054      &) cycle
2055 C         endif
2056           if (itel(j).eq.0) goto 1216
2057           ind=ind+1
2058           iteli=itel(i)
2059           itelj=itel(j)
2060           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2061           aaa=app(iteli,itelj)
2062           bbb=bpp(iteli,itelj)
2063 C Diagnostics only!!!
2064 c         aaa=0.0D0
2065 c         bbb=0.0D0
2066 c         ael6i=0.0D0
2067 c         ael3i=0.0D0
2068 C End diagnostics
2069           ael6i=ael6(iteli,itelj)
2070           ael3i=ael3(iteli,itelj)
2071           dxj=dc(1,j)
2072           dyj=dc(2,j)
2073           dzj=dc(3,j)
2074           dx_normj=dc_norm(1,j)
2075           dy_normj=dc_norm(2,j)
2076           dz_normj=dc_norm(3,j)
2077           xj=c(1,j)+0.5D0*dxj
2078           yj=c(2,j)+0.5D0*dyj
2079           zj=c(3,j)+0.5D0*dzj
2080          xj=mod(xj,boxxsize)
2081           if (xj.lt.0) xj=xj+boxxsize
2082           yj=mod(yj,boxysize)
2083           if (yj.lt.0) yj=yj+boxysize
2084           zj=mod(zj,boxzsize)
2085           if (zj.lt.0) zj=zj+boxzsize
2086       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2087       xj_safe=xj
2088       yj_safe=yj
2089       zj_safe=zj
2090       isubchap=0
2091       do xshift=-1,1
2092       do yshift=-1,1
2093       do zshift=-1,1
2094           xj=xj_safe+xshift*boxxsize
2095           yj=yj_safe+yshift*boxysize
2096           zj=zj_safe+zshift*boxzsize
2097           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2098           if(dist_temp.lt.dist_init) then
2099             dist_init=dist_temp
2100             xj_temp=xj
2101             yj_temp=yj
2102             zj_temp=zj
2103             isubchap=1
2104           endif
2105        enddo
2106        enddo
2107        enddo
2108        if (isubchap.eq.1) then
2109           xj=xj_temp-xmedi
2110           yj=yj_temp-ymedi
2111           zj=zj_temp-zmedi
2112        else
2113           xj=xj_safe-xmedi
2114           yj=yj_safe-ymedi
2115           zj=zj_safe-zmedi
2116        endif
2117
2118           rij=xj*xj+yj*yj+zj*zj
2119             sss=sscale(sqrt(rij))
2120             sssgrad=sscagrad(sqrt(rij))
2121           rrmij=1.0D0/rij
2122           rij=dsqrt(rij)
2123           rmij=1.0D0/rij
2124           r3ij=rrmij*rmij
2125           r6ij=r3ij*r3ij
2126           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2127           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2128           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2129           fac=cosa-3.0D0*cosb*cosg
2130           ev1=aaa*r6ij*r6ij
2131 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2132           if (j.eq.i+2) ev1=scal_el*ev1
2133           ev2=bbb*r6ij
2134           fac3=ael6i*r6ij
2135           fac4=ael3i*r3ij
2136           evdwij=ev1+ev2
2137           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2138           el2=fac4*fac
2139           eesij=el1+el2
2140 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2141 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2142           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2143           if (shield_mode.gt.0) then
2144 C          fac_shield(i)=0.4
2145 C          fac_shield(j)=0.6
2146 C#define DEBUG
2147 #ifdef DEBUG
2148           write(iout,*) "ees_compon",i,j,el1,el2,
2149      &    fac_shield(i),fac_shield(j)
2150 #endif
2151 C#undef DEBUG
2152           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2153           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2154           eesij=(el1+el2)
2155           ees=ees+eesij
2156           else
2157           fac_shield(i)=1.0
2158           fac_shield(j)=1.0
2159           eesij=(el1+el2)
2160           ees=ees+eesij
2161           endif
2162 C          ees=ees+eesij
2163           evdw1=evdw1+evdwij*sss
2164 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2165 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2166 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2167 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2168 C
2169 C Calculate contributions to the Cartesian gradient.
2170 C
2171 #ifdef SPLITELE
2172           facvdw=-6*rrmij*(ev1+evdwij)*sss
2173           facel=-3*rrmij*(el1+eesij)
2174           fac1=fac
2175           erij(1)=xj*rmij
2176           erij(2)=yj*rmij
2177           erij(3)=zj*rmij
2178           if (calc_grad) then
2179 *
2180 * Radial derivatives. First process both termini of the fragment (i,j)
2181 *
2182           ggg(1)=facel*xj
2183           ggg(2)=facel*yj
2184           ggg(3)=facel*zj
2185
2186           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2187      &  (shield_mode.gt.0)) then
2188 C          print *,i,j
2189           do ilist=1,ishield_list(i)
2190            iresshield=shield_list(ilist,i)
2191            do k=1,3
2192            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2193      &      *2.0
2194            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2195      &              rlocshield
2196      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2197             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2198 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2199 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2200 C             if (iresshield.gt.i) then
2201 C               do ishi=i+1,iresshield-1
2202 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2203 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2204 C
2205 C              enddo
2206 C             else
2207 C               do ishi=iresshield,i
2208 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2209 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2210 C
2211 C               enddo
2212 C              endif
2213 C           enddo
2214 C          enddo
2215            enddo
2216           enddo
2217           do ilist=1,ishield_list(j)
2218            iresshield=shield_list(ilist,j)
2219            do k=1,3
2220            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2221      &     *2.0
2222            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2223      &              rlocshield
2224      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2225            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2226            enddo
2227           enddo
2228
2229           do k=1,3
2230             gshieldc(k,i)=gshieldc(k,i)+
2231      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2232             gshieldc(k,j)=gshieldc(k,j)+
2233      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2234             gshieldc(k,i-1)=gshieldc(k,i-1)+
2235      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2236             gshieldc(k,j-1)=gshieldc(k,j-1)+
2237      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2238
2239            enddo
2240            endif
2241
2242           do k=1,3
2243             ghalf=0.5D0*ggg(k)
2244             gelc(k,i)=gelc(k,i)+ghalf
2245             gelc(k,j)=gelc(k,j)+ghalf
2246           enddo
2247 *
2248 * Loop over residues i+1 thru j-1.
2249 *
2250           do k=i+1,j-1
2251             do l=1,3
2252               gelc(l,k)=gelc(l,k)+ggg(l)
2253             enddo
2254           enddo
2255 C          ggg(1)=facvdw*xj
2256 C          ggg(2)=facvdw*yj
2257 C          ggg(3)=facvdw*zj
2258           if (sss.gt.0.0) then
2259           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2260           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2261           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2262           else
2263           ggg(1)=0.0
2264           ggg(2)=0.0
2265           ggg(3)=0.0
2266           endif
2267           do k=1,3
2268             ghalf=0.5D0*ggg(k)
2269             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2270             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2271           enddo
2272 *
2273 * Loop over residues i+1 thru j-1.
2274 *
2275           do k=i+1,j-1
2276             do l=1,3
2277               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2278             enddo
2279           enddo
2280 #else
2281           facvdw=(ev1+evdwij)*sss
2282           facel=el1+eesij
2283           fac1=fac
2284           fac=-3*rrmij*(facvdw+facvdw+facel)
2285           erij(1)=xj*rmij
2286           erij(2)=yj*rmij
2287           erij(3)=zj*rmij
2288           if (calc_grad) then
2289 *
2290 * Radial derivatives. First process both termini of the fragment (i,j)
2291 *
2292           ggg(1)=fac*xj
2293           ggg(2)=fac*yj
2294           ggg(3)=fac*zj
2295           do k=1,3
2296             ghalf=0.5D0*ggg(k)
2297             gelc(k,i)=gelc(k,i)+ghalf
2298             gelc(k,j)=gelc(k,j)+ghalf
2299           enddo
2300 *
2301 * Loop over residues i+1 thru j-1.
2302 *
2303           do k=i+1,j-1
2304             do l=1,3
2305               gelc(l,k)=gelc(l,k)+ggg(l)
2306             enddo
2307           enddo
2308 #endif
2309 *
2310 * Angular part
2311 *
2312           ecosa=2.0D0*fac3*fac1+fac4
2313           fac4=-3.0D0*fac4
2314           fac3=-6.0D0*fac3
2315           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2316           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2317           do k=1,3
2318             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2319             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2320           enddo
2321 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2322 cd   &          (dcosg(k),k=1,3)
2323           do k=1,3
2324             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2325      &      *fac_shield(i)**2*fac_shield(j)**2
2326           enddo
2327           do k=1,3
2328             ghalf=0.5D0*ggg(k)
2329             gelc(k,i)=gelc(k,i)+ghalf
2330      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2331      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2332      &           *fac_shield(i)**2*fac_shield(j)**2
2333
2334             gelc(k,j)=gelc(k,j)+ghalf
2335      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2336      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2337      &           *fac_shield(i)**2*fac_shield(j)**2
2338           enddo
2339           do k=i+1,j-1
2340             do l=1,3
2341               gelc(l,k)=gelc(l,k)+ggg(l)
2342             enddo
2343           enddo
2344           endif
2345
2346           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2347      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2348      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2349 C
2350 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2351 C   energy of a peptide unit is assumed in the form of a second-order
2352 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2353 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2354 C   are computed for EVERY pair of non-contiguous peptide groups.
2355 C
2356           if (j.lt.nres-1) then
2357             j1=j+1
2358             j2=j-1
2359           else
2360             j1=j-1
2361             j2=j-2
2362           endif
2363           kkk=0
2364           do k=1,2
2365             do l=1,2
2366               kkk=kkk+1
2367               muij(kkk)=mu(k,i)*mu(l,j)
2368             enddo
2369           enddo
2370 cd         write (iout,*) 'EELEC: i',i,' j',j
2371 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2372 cd          write(iout,*) 'muij',muij
2373           ury=scalar(uy(1,i),erij)
2374           urz=scalar(uz(1,i),erij)
2375           vry=scalar(uy(1,j),erij)
2376           vrz=scalar(uz(1,j),erij)
2377           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2378           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2379           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2380           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2381 C For diagnostics only
2382 cd          a22=1.0d0
2383 cd          a23=1.0d0
2384 cd          a32=1.0d0
2385 cd          a33=1.0d0
2386           fac=dsqrt(-ael6i)*r3ij
2387 cd          write (2,*) 'fac=',fac
2388 C For diagnostics only
2389 cd          fac=1.0d0
2390           a22=a22*fac
2391           a23=a23*fac
2392           a32=a32*fac
2393           a33=a33*fac
2394 cd          write (iout,'(4i5,4f10.5)')
2395 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2396 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2397 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2398 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2399 cd          write (iout,'(4f10.5)')
2400 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2401 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2402 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2403 cd           write (iout,'(2i3,9f10.5/)') i,j,
2404 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2405           if (calc_grad) then
2406 C Derivatives of the elements of A in virtual-bond vectors
2407           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2408 cd          do k=1,3
2409 cd            do l=1,3
2410 cd              erder(k,l)=0.0d0
2411 cd            enddo
2412 cd          enddo
2413           do k=1,3
2414             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2415             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2416             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2417             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2418             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2419             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2420             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2421             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2422             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2423             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2424             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2425             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2426           enddo
2427 cd          do k=1,3
2428 cd            do l=1,3
2429 cd              uryg(k,l)=0.0d0
2430 cd              urzg(k,l)=0.0d0
2431 cd              vryg(k,l)=0.0d0
2432 cd              vrzg(k,l)=0.0d0
2433 cd            enddo
2434 cd          enddo
2435 C Compute radial contributions to the gradient
2436           facr=-3.0d0*rrmij
2437           a22der=a22*facr
2438           a23der=a23*facr
2439           a32der=a32*facr
2440           a33der=a33*facr
2441 cd          a22der=0.0d0
2442 cd          a23der=0.0d0
2443 cd          a32der=0.0d0
2444 cd          a33der=0.0d0
2445           agg(1,1)=a22der*xj
2446           agg(2,1)=a22der*yj
2447           agg(3,1)=a22der*zj
2448           agg(1,2)=a23der*xj
2449           agg(2,2)=a23der*yj
2450           agg(3,2)=a23der*zj
2451           agg(1,3)=a32der*xj
2452           agg(2,3)=a32der*yj
2453           agg(3,3)=a32der*zj
2454           agg(1,4)=a33der*xj
2455           agg(2,4)=a33der*yj
2456           agg(3,4)=a33der*zj
2457 C Add the contributions coming from er
2458           fac3=-3.0d0*fac
2459           do k=1,3
2460             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2461             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2462             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2463             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2464           enddo
2465           do k=1,3
2466 C Derivatives in DC(i)
2467             ghalf1=0.5d0*agg(k,1)
2468             ghalf2=0.5d0*agg(k,2)
2469             ghalf3=0.5d0*agg(k,3)
2470             ghalf4=0.5d0*agg(k,4)
2471             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2472      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2473             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2474      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2475             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2476      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2477             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2478      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2479 C Derivatives in DC(i+1)
2480             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2481      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2482             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2483      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2484             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2485      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2486             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2487      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2488 C Derivatives in DC(j)
2489             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2490      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2491             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2492      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2493             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2494      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2495             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2496      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2497 C Derivatives in DC(j+1) or DC(nres-1)
2498             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2499      &      -3.0d0*vryg(k,3)*ury)
2500             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2501      &      -3.0d0*vrzg(k,3)*ury)
2502             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2503      &      -3.0d0*vryg(k,3)*urz)
2504             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2505      &      -3.0d0*vrzg(k,3)*urz)
2506 cd            aggi(k,1)=ghalf1
2507 cd            aggi(k,2)=ghalf2
2508 cd            aggi(k,3)=ghalf3
2509 cd            aggi(k,4)=ghalf4
2510 C Derivatives in DC(i+1)
2511 cd            aggi1(k,1)=agg(k,1)
2512 cd            aggi1(k,2)=agg(k,2)
2513 cd            aggi1(k,3)=agg(k,3)
2514 cd            aggi1(k,4)=agg(k,4)
2515 C Derivatives in DC(j)
2516 cd            aggj(k,1)=ghalf1
2517 cd            aggj(k,2)=ghalf2
2518 cd            aggj(k,3)=ghalf3
2519 cd            aggj(k,4)=ghalf4
2520 C Derivatives in DC(j+1)
2521 cd            aggj1(k,1)=0.0d0
2522 cd            aggj1(k,2)=0.0d0
2523 cd            aggj1(k,3)=0.0d0
2524 cd            aggj1(k,4)=0.0d0
2525             if (j.eq.nres-1 .and. i.lt.j-2) then
2526               do l=1,4
2527                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2528 cd                aggj1(k,l)=agg(k,l)
2529               enddo
2530             endif
2531           enddo
2532           endif
2533 c          goto 11111
2534 C Check the loc-el terms by numerical integration
2535           acipa(1,1)=a22
2536           acipa(1,2)=a23
2537           acipa(2,1)=a32
2538           acipa(2,2)=a33
2539           a22=-a22
2540           a23=-a23
2541           do l=1,2
2542             do k=1,3
2543               agg(k,l)=-agg(k,l)
2544               aggi(k,l)=-aggi(k,l)
2545               aggi1(k,l)=-aggi1(k,l)
2546               aggj(k,l)=-aggj(k,l)
2547               aggj1(k,l)=-aggj1(k,l)
2548             enddo
2549           enddo
2550           if (j.lt.nres-1) then
2551             a22=-a22
2552             a32=-a32
2553             do l=1,3,2
2554               do k=1,3
2555                 agg(k,l)=-agg(k,l)
2556                 aggi(k,l)=-aggi(k,l)
2557                 aggi1(k,l)=-aggi1(k,l)
2558                 aggj(k,l)=-aggj(k,l)
2559                 aggj1(k,l)=-aggj1(k,l)
2560               enddo
2561             enddo
2562           else
2563             a22=-a22
2564             a23=-a23
2565             a32=-a32
2566             a33=-a33
2567             do l=1,4
2568               do k=1,3
2569                 agg(k,l)=-agg(k,l)
2570                 aggi(k,l)=-aggi(k,l)
2571                 aggi1(k,l)=-aggi1(k,l)
2572                 aggj(k,l)=-aggj(k,l)
2573                 aggj1(k,l)=-aggj1(k,l)
2574               enddo
2575             enddo
2576           endif
2577           ENDIF ! WCORR
2578 11111     continue
2579           IF (wel_loc.gt.0.0d0) THEN
2580 C Contribution to the local-electrostatic energy coming from the i-j pair
2581           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2582      &     +a33*muij(4)
2583 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2584 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2585           if (shield_mode.eq.0) then
2586            fac_shield(i)=1.0
2587            fac_shield(j)=1.0
2588 C          else
2589 C           fac_shield(i)=0.4
2590 C           fac_shield(j)=0.6
2591           endif
2592           eel_loc_ij=eel_loc_ij
2593      &    *fac_shield(i)*fac_shield(j)
2594           eel_loc=eel_loc+eel_loc_ij
2595 C Partial derivatives in virtual-bond dihedral angles gamma
2596           if (calc_grad) then
2597           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2598      &  (shield_mode.gt.0)) then
2599 C          print *,i,j
2600
2601           do ilist=1,ishield_list(i)
2602            iresshield=shield_list(ilist,i)
2603            do k=1,3
2604            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2605      &                                          /fac_shield(i)
2606 C     &      *2.0
2607            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2608      &              rlocshield
2609      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2610             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2611      &      +rlocshield
2612            enddo
2613           enddo
2614           do ilist=1,ishield_list(j)
2615            iresshield=shield_list(ilist,j)
2616            do k=1,3
2617            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2618      &                                       /fac_shield(j)
2619 C     &     *2.0
2620            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2621      &              rlocshield
2622      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2623            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2624      &             +rlocshield
2625
2626            enddo
2627           enddo
2628           do k=1,3
2629             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2630      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2631             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2632      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2633             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2634      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2635             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2636      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2637            enddo
2638            endif
2639           if (i.gt.1)
2640      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2641      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2642      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2643      &    *fac_shield(i)*fac_shield(j)
2644           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2645      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2646      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2647      &    *fac_shield(i)*fac_shield(j)
2648
2649 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2650 cd          write(iout,*) 'agg  ',agg
2651 cd          write(iout,*) 'aggi ',aggi
2652 cd          write(iout,*) 'aggi1',aggi1
2653 cd          write(iout,*) 'aggj ',aggj
2654 cd          write(iout,*) 'aggj1',aggj1
2655
2656 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2657           do l=1,3
2658             ggg(l)=agg(l,1)*muij(1)+
2659      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2660      &    *fac_shield(i)*fac_shield(j)
2661
2662           enddo
2663           do k=i+2,j2
2664             do l=1,3
2665               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2666             enddo
2667           enddo
2668 C Remaining derivatives of eello
2669           do l=1,3
2670             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2671      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2672      &    *fac_shield(i)*fac_shield(j)
2673
2674             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2675      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2676      &    *fac_shield(i)*fac_shield(j)
2677
2678             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2679      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2680      &    *fac_shield(i)*fac_shield(j)
2681
2682             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2683      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2684      &    *fac_shield(i)*fac_shield(j)
2685
2686           enddo
2687           endif
2688           ENDIF
2689           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2690 C Contributions from turns
2691             a_temp(1,1)=a22
2692             a_temp(1,2)=a23
2693             a_temp(2,1)=a32
2694             a_temp(2,2)=a33
2695             call eturn34(i,j,eello_turn3,eello_turn4)
2696           endif
2697 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2698           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2699 C
2700 C Calculate the contact function. The ith column of the array JCONT will
2701 C contain the numbers of atoms that make contacts with the atom I (of numbers
2702 C greater than I). The arrays FACONT and GACONT will contain the values of
2703 C the contact function and its derivative.
2704 c           r0ij=1.02D0*rpp(iteli,itelj)
2705 c           r0ij=1.11D0*rpp(iteli,itelj)
2706             r0ij=2.20D0*rpp(iteli,itelj)
2707 c           r0ij=1.55D0*rpp(iteli,itelj)
2708             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2709             if (fcont.gt.0.0D0) then
2710               num_conti=num_conti+1
2711               if (num_conti.gt.maxconts) then
2712                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2713      &                         ' will skip next contacts for this conf.'
2714               else
2715                 jcont_hb(num_conti,i)=j
2716                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2717      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2718 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2719 C  terms.
2720                 d_cont(num_conti,i)=rij
2721 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2722 C     --- Electrostatic-interaction matrix ---
2723                 a_chuj(1,1,num_conti,i)=a22
2724                 a_chuj(1,2,num_conti,i)=a23
2725                 a_chuj(2,1,num_conti,i)=a32
2726                 a_chuj(2,2,num_conti,i)=a33
2727 C     --- Gradient of rij
2728                 do kkk=1,3
2729                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2730                 enddo
2731 c             if (i.eq.1) then
2732 c                a_chuj(1,1,num_conti,i)=-0.61d0
2733 c                a_chuj(1,2,num_conti,i)= 0.4d0
2734 c                a_chuj(2,1,num_conti,i)= 0.65d0
2735 c                a_chuj(2,2,num_conti,i)= 0.50d0
2736 c             else if (i.eq.2) then
2737 c                a_chuj(1,1,num_conti,i)= 0.0d0
2738 c                a_chuj(1,2,num_conti,i)= 0.0d0
2739 c                a_chuj(2,1,num_conti,i)= 0.0d0
2740 c                a_chuj(2,2,num_conti,i)= 0.0d0
2741 c             endif
2742 C     --- and its gradients
2743 cd                write (iout,*) 'i',i,' j',j
2744 cd                do kkk=1,3
2745 cd                write (iout,*) 'iii 1 kkk',kkk
2746 cd                write (iout,*) agg(kkk,:)
2747 cd                enddo
2748 cd                do kkk=1,3
2749 cd                write (iout,*) 'iii 2 kkk',kkk
2750 cd                write (iout,*) aggi(kkk,:)
2751 cd                enddo
2752 cd                do kkk=1,3
2753 cd                write (iout,*) 'iii 3 kkk',kkk
2754 cd                write (iout,*) aggi1(kkk,:)
2755 cd                enddo
2756 cd                do kkk=1,3
2757 cd                write (iout,*) 'iii 4 kkk',kkk
2758 cd                write (iout,*) aggj(kkk,:)
2759 cd                enddo
2760 cd                do kkk=1,3
2761 cd                write (iout,*) 'iii 5 kkk',kkk
2762 cd                write (iout,*) aggj1(kkk,:)
2763 cd                enddo
2764                 kkll=0
2765                 do k=1,2
2766                   do l=1,2
2767                     kkll=kkll+1
2768                     do m=1,3
2769                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2770                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2771                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2772                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2773                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2774 c                      do mm=1,5
2775 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2776 c                      enddo
2777                     enddo
2778                   enddo
2779                 enddo
2780                 ENDIF
2781                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2782 C Calculate contact energies
2783                 cosa4=4.0D0*cosa
2784                 wij=cosa-3.0D0*cosb*cosg
2785                 cosbg1=cosb+cosg
2786                 cosbg2=cosb-cosg
2787 c               fac3=dsqrt(-ael6i)/r0ij**3
2788                 fac3=dsqrt(-ael6i)*r3ij
2789                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2790                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2791                 if (shield_mode.eq.0) then
2792                 fac_shield(i)=1.0d0
2793                 fac_shield(j)=1.0d0
2794                 else
2795                 ees0plist(num_conti,i)=j
2796 C                fac_shield(i)=0.4d0
2797 C                fac_shield(j)=0.6d0
2798                 endif
2799 c               ees0mij=0.0D0
2800                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2801      &          *fac_shield(i)*fac_shield(j)
2802
2803                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2804      &          *fac_shield(i)*fac_shield(j)
2805
2806 C Diagnostics. Comment out or remove after debugging!
2807 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2808 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2809 c               ees0m(num_conti,i)=0.0D0
2810 C End diagnostics.
2811 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2812 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2813                 facont_hb(num_conti,i)=fcont
2814                 if (calc_grad) then
2815 C Angular derivatives of the contact function
2816                 ees0pij1=fac3/ees0pij
2817                 ees0mij1=fac3/ees0mij
2818                 fac3p=-3.0D0*fac3*rrmij
2819                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2820                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2821 c               ees0mij1=0.0D0
2822                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2823                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2824                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2825                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2826                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2827                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2828                 ecosap=ecosa1+ecosa2
2829                 ecosbp=ecosb1+ecosb2
2830                 ecosgp=ecosg1+ecosg2
2831                 ecosam=ecosa1-ecosa2
2832                 ecosbm=ecosb1-ecosb2
2833                 ecosgm=ecosg1-ecosg2
2834 C Diagnostics
2835 c               ecosap=ecosa1
2836 c               ecosbp=ecosb1
2837 c               ecosgp=ecosg1
2838 c               ecosam=0.0D0
2839 c               ecosbm=0.0D0
2840 c               ecosgm=0.0D0
2841 C End diagnostics
2842                 fprimcont=fprimcont/rij
2843 cd              facont_hb(num_conti,i)=1.0D0
2844 C Following line is for diagnostics.
2845 cd              fprimcont=0.0D0
2846                 do k=1,3
2847                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2848                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2849                 enddo
2850                 do k=1,3
2851                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2852                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2853                 enddo
2854                 gggp(1)=gggp(1)+ees0pijp*xj
2855                 gggp(2)=gggp(2)+ees0pijp*yj
2856                 gggp(3)=gggp(3)+ees0pijp*zj
2857                 gggm(1)=gggm(1)+ees0mijp*xj
2858                 gggm(2)=gggm(2)+ees0mijp*yj
2859                 gggm(3)=gggm(3)+ees0mijp*zj
2860 C Derivatives due to the contact function
2861                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2862                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2863                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2864                 do k=1,3
2865                   ghalfp=0.5D0*gggp(k)
2866                   ghalfm=0.5D0*gggm(k)
2867                   gacontp_hb1(k,num_conti,i)=ghalfp
2868      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2869      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2870      &          *fac_shield(i)*fac_shield(j)
2871
2872                   gacontp_hb2(k,num_conti,i)=ghalfp
2873      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2874      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2875      &          *fac_shield(i)*fac_shield(j)
2876
2877                   gacontp_hb3(k,num_conti,i)=gggp(k)
2878      &          *fac_shield(i)*fac_shield(j)
2879
2880                   gacontm_hb1(k,num_conti,i)=ghalfm
2881      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2882      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2883      &          *fac_shield(i)*fac_shield(j)
2884
2885                   gacontm_hb2(k,num_conti,i)=ghalfm
2886      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2887      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2888      &          *fac_shield(i)*fac_shield(j)
2889
2890                   gacontm_hb3(k,num_conti,i)=gggm(k)
2891      &          *fac_shield(i)*fac_shield(j)
2892
2893                 enddo
2894                 endif
2895 C Diagnostics. Comment out or remove after debugging!
2896 cdiag           do k=1,3
2897 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2898 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2899 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2900 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2901 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2902 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2903 cdiag           enddo
2904               ENDIF ! wcorr
2905               endif  ! num_conti.le.maxconts
2906             endif  ! fcont.gt.0
2907           endif    ! j.gt.i+1
2908  1216     continue
2909         enddo ! j
2910         num_cont_hb(i)=num_conti
2911  1215   continue
2912       enddo   ! i
2913 cd      do i=1,nres
2914 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2915 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2916 cd      enddo
2917 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2918 ccc      eel_loc=eel_loc+eello_turn3
2919       return
2920       end
2921 C-----------------------------------------------------------------------------
2922       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2923 C Third- and fourth-order contributions from turns
2924       implicit real*8 (a-h,o-z)
2925       include 'DIMENSIONS'
2926       include 'sizesclu.dat'
2927       include 'COMMON.IOUNITS'
2928       include 'COMMON.GEO'
2929       include 'COMMON.VAR'
2930       include 'COMMON.LOCAL'
2931       include 'COMMON.CHAIN'
2932       include 'COMMON.DERIV'
2933       include 'COMMON.INTERACT'
2934       include 'COMMON.CONTACTS'
2935       include 'COMMON.TORSION'
2936       include 'COMMON.VECTORS'
2937       include 'COMMON.FFIELD'
2938       include 'COMMON.SHIELD'
2939       include 'COMMON.CONTROL'
2940
2941       dimension ggg(3)
2942       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2943      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2944      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2945       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2946      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2947       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2948       if (j.eq.i+2) then
2949       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2950 C changes suggested by Ana to avoid out of bounds
2951 C     & .or.((i+5).gt.nres)
2952 C     & .or.((i-1).le.0)
2953 C end of changes suggested by Ana
2954      &    .or. itype(i+2).eq.ntyp1
2955      &    .or. itype(i+3).eq.ntyp1
2956 C     &    .or. itype(i+5).eq.ntyp1
2957 C     &    .or. itype(i).eq.ntyp1
2958 C     &    .or. itype(i-1).eq.ntyp1
2959      &    ) goto 179
2960
2961 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2962 C
2963 C               Third-order contributions
2964 C
2965 C                 (i+2)o----(i+3)
2966 C                      | |
2967 C                      | |
2968 C                 (i+1)o----i
2969 C
2970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2971 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2972         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2973         call transpose2(auxmat(1,1),auxmat1(1,1))
2974         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2975         if (shield_mode.eq.0) then
2976         fac_shield(i)=1.0
2977         fac_shield(j)=1.0
2978 C        else
2979 C        fac_shield(i)=0.4
2980 C        fac_shield(j)=0.6
2981         endif
2982         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2983      &  *fac_shield(i)*fac_shield(j)
2984         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
2985      &  *fac_shield(i)*fac_shield(j)
2986
2987 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2988 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2989 cd     &    ' eello_turn3_num',4*eello_turn3_num
2990         if (calc_grad) then
2991 C Derivatives in shield mode
2992           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2993      &  (shield_mode.gt.0)) then
2994 C          print *,i,j
2995
2996           do ilist=1,ishield_list(i)
2997            iresshield=shield_list(ilist,i)
2998            do k=1,3
2999            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3000 C     &      *2.0
3001            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3002      &              rlocshield
3003      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3004             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3005      &      +rlocshield
3006            enddo
3007           enddo
3008           do ilist=1,ishield_list(j)
3009            iresshield=shield_list(ilist,j)
3010            do k=1,3
3011            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3012 C     &     *2.0
3013            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3014      &              rlocshield
3015      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3016            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3017      &             +rlocshield
3018
3019            enddo
3020           enddo
3021
3022           do k=1,3
3023             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3024      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3025             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3026      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3027             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3028      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3029             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3030      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3031            enddo
3032            endif
3033
3034 C Derivatives in gamma(i)
3035         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3036         call transpose2(auxmat2(1,1),pizda(1,1))
3037         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3038         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3039      &   *fac_shield(i)*fac_shield(j)
3040
3041 C Derivatives in gamma(i+1)
3042         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3043         call transpose2(auxmat2(1,1),pizda(1,1))
3044         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3045         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3046      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3047      &   *fac_shield(i)*fac_shield(j)
3048
3049 C Cartesian derivatives
3050         do l=1,3
3051           a_temp(1,1)=aggi(l,1)
3052           a_temp(1,2)=aggi(l,2)
3053           a_temp(2,1)=aggi(l,3)
3054           a_temp(2,2)=aggi(l,4)
3055           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3056           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3057      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3058      &   *fac_shield(i)*fac_shield(j)
3059
3060           a_temp(1,1)=aggi1(l,1)
3061           a_temp(1,2)=aggi1(l,2)
3062           a_temp(2,1)=aggi1(l,3)
3063           a_temp(2,2)=aggi1(l,4)
3064           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3065           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3066      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3067      &   *fac_shield(i)*fac_shield(j)
3068
3069           a_temp(1,1)=aggj(l,1)
3070           a_temp(1,2)=aggj(l,2)
3071           a_temp(2,1)=aggj(l,3)
3072           a_temp(2,2)=aggj(l,4)
3073           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3074           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3075      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3076      &   *fac_shield(i)*fac_shield(j)
3077
3078           a_temp(1,1)=aggj1(l,1)
3079           a_temp(1,2)=aggj1(l,2)
3080           a_temp(2,1)=aggj1(l,3)
3081           a_temp(2,2)=aggj1(l,4)
3082           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3083           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3084      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3085      &   *fac_shield(i)*fac_shield(j)
3086
3087         enddo
3088         endif
3089   179 continue
3090       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3091       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3092 C changes suggested by Ana to avoid out of bounds
3093 C     & .or.((i+5).gt.nres)
3094 C     & .or.((i-1).le.0)
3095 C end of changes suggested by Ana
3096      &    .or. itype(i+3).eq.ntyp1
3097      &    .or. itype(i+4).eq.ntyp1
3098 C     &    .or. itype(i+5).eq.ntyp1
3099      &    .or. itype(i).eq.ntyp1
3100 C     &    .or. itype(i-1).eq.ntyp1
3101      &    ) goto 178
3102
3103 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3104 C
3105 C               Fourth-order contributions
3106 C
3107 C                 (i+3)o----(i+4)
3108 C                     /  |
3109 C               (i+2)o   |
3110 C                     \  |
3111 C                 (i+1)o----i
3112 C
3113 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3114 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3115         iti1=itortyp(itype(i+1))
3116         iti2=itortyp(itype(i+2))
3117         iti3=itortyp(itype(i+3))
3118         call transpose2(EUg(1,1,i+1),e1t(1,1))
3119         call transpose2(Eug(1,1,i+2),e2t(1,1))
3120         call transpose2(Eug(1,1,i+3),e3t(1,1))
3121         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3122         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3123         s1=scalar2(b1(1,iti2),auxvec(1))
3124         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3125         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3126         s2=scalar2(b1(1,iti1),auxvec(1))
3127         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3128         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3129         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3130         if (shield_mode.eq.0) then
3131         fac_shield(i)=1.0
3132         fac_shield(j)=1.0
3133 C        else
3134 C        fac_shield(i)=0.4
3135 C        fac_shield(j)=0.6
3136         endif
3137         eello_turn4=eello_turn4-(s1+s2+s3)
3138      &  *fac_shield(i)*fac_shield(j)
3139         eello_t4=-(s1+s2+s3)
3140      &  *fac_shield(i)*fac_shield(j)
3141
3142 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3143 cd     &    ' eello_turn4_num',8*eello_turn4_num
3144 C Derivatives in gamma(i)
3145         if (calc_grad) then
3146           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3147      &  (shield_mode.gt.0)) then
3148 C          print *,i,j
3149
3150           do ilist=1,ishield_list(i)
3151            iresshield=shield_list(ilist,i)
3152            do k=1,3
3153            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3154 C     &      *2.0
3155            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3156      &              rlocshield
3157      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3158             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3159      &      +rlocshield
3160            enddo
3161           enddo
3162           do ilist=1,ishield_list(j)
3163            iresshield=shield_list(ilist,j)
3164            do k=1,3
3165            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3166 C     &     *2.0
3167            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3168      &              rlocshield
3169      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3170            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3171      &             +rlocshield
3172
3173            enddo
3174           enddo
3175
3176           do k=1,3
3177             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3178      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3179             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3180      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3181             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3182      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3183             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3184      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3185            enddo
3186            endif
3187
3188         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3189         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3190         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3191         s1=scalar2(b1(1,iti2),auxvec(1))
3192         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3193         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3194         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3195      &  *fac_shield(i)*fac_shield(j)
3196
3197 C Derivatives in gamma(i+1)
3198         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3199         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3200         s2=scalar2(b1(1,iti1),auxvec(1))
3201         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3202         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3203         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3204         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3205      &  *fac_shield(i)*fac_shield(j)
3206
3207 C Derivatives in gamma(i+2)
3208         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3209         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3210         s1=scalar2(b1(1,iti2),auxvec(1))
3211         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3212         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3213         s2=scalar2(b1(1,iti1),auxvec(1))
3214         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3215         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3216         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3217         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3218      &  *fac_shield(i)*fac_shield(j)
3219
3220 C Cartesian derivatives
3221 C Derivatives of this turn contributions in DC(i+2)
3222         if (j.lt.nres-1) then
3223           do l=1,3
3224             a_temp(1,1)=agg(l,1)
3225             a_temp(1,2)=agg(l,2)
3226             a_temp(2,1)=agg(l,3)
3227             a_temp(2,2)=agg(l,4)
3228             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3229             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3230             s1=scalar2(b1(1,iti2),auxvec(1))
3231             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3232             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3233             s2=scalar2(b1(1,iti1),auxvec(1))
3234             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3235             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3236             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3237             ggg(l)=-(s1+s2+s3)
3238             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3239      &  *fac_shield(i)*fac_shield(j)
3240
3241           enddo
3242         endif
3243 C Remaining derivatives of this turn contribution
3244         do l=1,3
3245           a_temp(1,1)=aggi(l,1)
3246           a_temp(1,2)=aggi(l,2)
3247           a_temp(2,1)=aggi(l,3)
3248           a_temp(2,2)=aggi(l,4)
3249           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3250           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3251           s1=scalar2(b1(1,iti2),auxvec(1))
3252           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3253           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3254           s2=scalar2(b1(1,iti1),auxvec(1))
3255           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3256           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3257           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3258           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3259      &  *fac_shield(i)*fac_shield(j)
3260
3261           a_temp(1,1)=aggi1(l,1)
3262           a_temp(1,2)=aggi1(l,2)
3263           a_temp(2,1)=aggi1(l,3)
3264           a_temp(2,2)=aggi1(l,4)
3265           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3266           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3267           s1=scalar2(b1(1,iti2),auxvec(1))
3268           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3269           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3270           s2=scalar2(b1(1,iti1),auxvec(1))
3271           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3272           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3273           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3274           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3275      &  *fac_shield(i)*fac_shield(j)
3276
3277           a_temp(1,1)=aggj(l,1)
3278           a_temp(1,2)=aggj(l,2)
3279           a_temp(2,1)=aggj(l,3)
3280           a_temp(2,2)=aggj(l,4)
3281           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3282           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3283           s1=scalar2(b1(1,iti2),auxvec(1))
3284           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3285           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3286           s2=scalar2(b1(1,iti1),auxvec(1))
3287           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3288           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3289           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3290           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3291      &  *fac_shield(i)*fac_shield(j)
3292
3293           a_temp(1,1)=aggj1(l,1)
3294           a_temp(1,2)=aggj1(l,2)
3295           a_temp(2,1)=aggj1(l,3)
3296           a_temp(2,2)=aggj1(l,4)
3297           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3298           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3299           s1=scalar2(b1(1,iti2),auxvec(1))
3300           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3301           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3302           s2=scalar2(b1(1,iti1),auxvec(1))
3303           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3304           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3305           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3306           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3307      &  *fac_shield(i)*fac_shield(j)
3308
3309         enddo
3310         endif
3311   178 continue
3312       endif
3313       return
3314       end
3315 C-----------------------------------------------------------------------------
3316       subroutine vecpr(u,v,w)
3317       implicit real*8(a-h,o-z)
3318       dimension u(3),v(3),w(3)
3319       w(1)=u(2)*v(3)-u(3)*v(2)
3320       w(2)=-u(1)*v(3)+u(3)*v(1)
3321       w(3)=u(1)*v(2)-u(2)*v(1)
3322       return
3323       end
3324 C-----------------------------------------------------------------------------
3325       subroutine unormderiv(u,ugrad,unorm,ungrad)
3326 C This subroutine computes the derivatives of a normalized vector u, given
3327 C the derivatives computed without normalization conditions, ugrad. Returns
3328 C ungrad.
3329       implicit none
3330       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3331       double precision vec(3)
3332       double precision scalar
3333       integer i,j
3334 c      write (2,*) 'ugrad',ugrad
3335 c      write (2,*) 'u',u
3336       do i=1,3
3337         vec(i)=scalar(ugrad(1,i),u(1))
3338       enddo
3339 c      write (2,*) 'vec',vec
3340       do i=1,3
3341         do j=1,3
3342           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3343         enddo
3344       enddo
3345 c      write (2,*) 'ungrad',ungrad
3346       return
3347       end
3348 C-----------------------------------------------------------------------------
3349       subroutine escp(evdw2,evdw2_14)
3350 C
3351 C This subroutine calculates the excluded-volume interaction energy between
3352 C peptide-group centers and side chains and its gradient in virtual-bond and
3353 C side-chain vectors.
3354 C
3355       implicit real*8 (a-h,o-z)
3356       include 'DIMENSIONS'
3357       include 'sizesclu.dat'
3358       include 'COMMON.GEO'
3359       include 'COMMON.VAR'
3360       include 'COMMON.LOCAL'
3361       include 'COMMON.CHAIN'
3362       include 'COMMON.DERIV'
3363       include 'COMMON.INTERACT'
3364       include 'COMMON.FFIELD'
3365       include 'COMMON.IOUNITS'
3366       dimension ggg(3)
3367       evdw2=0.0D0
3368       evdw2_14=0.0d0
3369 cd    print '(a)','Enter ESCP'
3370 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3371 c     &  ' scal14',scal14
3372       do i=iatscp_s,iatscp_e
3373         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3374         iteli=itel(i)
3375 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3376 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3377         if (iteli.eq.0) goto 1225
3378         xi=0.5D0*(c(1,i)+c(1,i+1))
3379         yi=0.5D0*(c(2,i)+c(2,i+1))
3380         zi=0.5D0*(c(3,i)+c(3,i+1))
3381 C    Returning the ith atom to box
3382           xi=mod(xi,boxxsize)
3383           if (xi.lt.0) xi=xi+boxxsize
3384           yi=mod(yi,boxysize)
3385           if (yi.lt.0) yi=yi+boxysize
3386           zi=mod(zi,boxzsize)
3387           if (zi.lt.0) zi=zi+boxzsize
3388
3389         do iint=1,nscp_gr(i)
3390
3391         do j=iscpstart(i,iint),iscpend(i,iint)
3392           itypj=iabs(itype(j))
3393           if (itypj.eq.ntyp1) cycle
3394 C Uncomment following three lines for SC-p interactions
3395 c         xj=c(1,nres+j)-xi
3396 c         yj=c(2,nres+j)-yi
3397 c         zj=c(3,nres+j)-zi
3398 C Uncomment following three lines for Ca-p interactions
3399           xj=c(1,j)
3400           yj=c(2,j)
3401           zj=c(3,j)
3402 C returning the jth atom to box
3403           xj=mod(xj,boxxsize)
3404           if (xj.lt.0) xj=xj+boxxsize
3405           yj=mod(yj,boxysize)
3406           if (yj.lt.0) yj=yj+boxysize
3407           zj=mod(zj,boxzsize)
3408           if (zj.lt.0) zj=zj+boxzsize
3409       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3410       xj_safe=xj
3411       yj_safe=yj
3412       zj_safe=zj
3413       subchap=0
3414 C Finding the closest jth atom
3415       do xshift=-1,1
3416       do yshift=-1,1
3417       do zshift=-1,1
3418           xj=xj_safe+xshift*boxxsize
3419           yj=yj_safe+yshift*boxysize
3420           zj=zj_safe+zshift*boxzsize
3421           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3422           if(dist_temp.lt.dist_init) then
3423             dist_init=dist_temp
3424             xj_temp=xj
3425             yj_temp=yj
3426             zj_temp=zj
3427             subchap=1
3428           endif
3429        enddo
3430        enddo
3431        enddo
3432        if (subchap.eq.1) then
3433           xj=xj_temp-xi
3434           yj=yj_temp-yi
3435           zj=zj_temp-zi
3436        else
3437           xj=xj_safe-xi
3438           yj=yj_safe-yi
3439           zj=zj_safe-zi
3440        endif
3441
3442           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3443 C sss is scaling function for smoothing the cutoff gradient otherwise
3444 C the gradient would not be continuouse
3445           sss=sscale(1.0d0/(dsqrt(rrij)))
3446           if (sss.le.0.0d0) cycle
3447           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3448           fac=rrij**expon2
3449           e1=fac*fac*aad(itypj,iteli)
3450           e2=fac*bad(itypj,iteli)
3451           if (iabs(j-i) .le. 2) then
3452             e1=scal14*e1
3453             e2=scal14*e2
3454             evdw2_14=evdw2_14+(e1+e2)*sss
3455           endif
3456           evdwij=e1+e2
3457 c          write (iout,*) i,j,evdwij
3458           evdw2=evdw2+evdwij*sss
3459           if (calc_grad) then
3460 C
3461 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3462 C
3463            fac=-(evdwij+e1)*rrij*sss
3464            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3465           ggg(1)=xj*fac
3466           ggg(2)=yj*fac
3467           ggg(3)=zj*fac
3468           if (j.lt.i) then
3469 cd          write (iout,*) 'j<i'
3470 C Uncomment following three lines for SC-p interactions
3471 c           do k=1,3
3472 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3473 c           enddo
3474           else
3475 cd          write (iout,*) 'j>i'
3476             do k=1,3
3477               ggg(k)=-ggg(k)
3478 C Uncomment following line for SC-p interactions
3479 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3480             enddo
3481           endif
3482           do k=1,3
3483             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3484           enddo
3485           kstart=min0(i+1,j)
3486           kend=max0(i-1,j-1)
3487 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3488 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3489           do k=kstart,kend
3490             do l=1,3
3491               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3492             enddo
3493           enddo
3494           endif
3495         enddo
3496         enddo ! iint
3497  1225   continue
3498       enddo ! i
3499       do i=1,nct
3500         do j=1,3
3501           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3502           gradx_scp(j,i)=expon*gradx_scp(j,i)
3503         enddo
3504       enddo
3505 C******************************************************************************
3506 C
3507 C                              N O T E !!!
3508 C
3509 C To save time the factor EXPON has been extracted from ALL components
3510 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3511 C use!
3512 C
3513 C******************************************************************************
3514       return
3515       end
3516 C--------------------------------------------------------------------------
3517       subroutine edis(ehpb)
3518 C
3519 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3520 C
3521       implicit real*8 (a-h,o-z)
3522       include 'DIMENSIONS'
3523       include 'sizesclu.dat'
3524       include 'COMMON.SBRIDGE'
3525       include 'COMMON.CHAIN'
3526       include 'COMMON.DERIV'
3527       include 'COMMON.VAR'
3528       include 'COMMON.INTERACT'
3529       include 'COMMON.CONTROL'
3530       dimension ggg(3)
3531       ehpb=0.0D0
3532 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3533 cd    print *,'link_start=',link_start,' link_end=',link_end
3534       if (link_end.eq.0) return
3535       do i=link_start,link_end
3536 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3537 C CA-CA distance used in regularization of structure.
3538         ii=ihpb(i)
3539         jj=jhpb(i)
3540 C iii and jjj point to the residues for which the distance is assigned.
3541         if (ii.gt.nres) then
3542           iii=ii-nres
3543           jjj=jj-nres
3544         else
3545           iii=ii
3546           jjj=jj
3547         endif
3548 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3549 C    distance and angle dependent SS bond potential.
3550 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3551 C     &  iabs(itype(jjj)).eq.1) then
3552 C          call ssbond_ene(iii,jjj,eij)
3553 C          ehpb=ehpb+2*eij
3554 C        else
3555        if (.not.dyn_ss .and. i.le.nss) then
3556          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3557      & iabs(itype(jjj)).eq.1) then
3558           call ssbond_ene(iii,jjj,eij)
3559           ehpb=ehpb+2*eij
3560            endif !ii.gt.neres
3561         else if (ii.gt.nres .and. jj.gt.nres) then
3562 c Restraints from contact prediction
3563           dd=dist(ii,jj)
3564           if (constr_dist.eq.11) then
3565 C            ehpb=ehpb+fordepth(i)**4.0d0
3566 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3567             ehpb=ehpb+fordepth(i)**4.0d0
3568      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3569             fac=fordepth(i)**4.0d0
3570      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3571 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3572 C     &    ehpb,fordepth(i),dd
3573 C             print *,"TUTU"
3574 C            write(iout,*) ehpb,"atu?"
3575 C            ehpb,"tu?"
3576 C            fac=fordepth(i)**4.0d0
3577 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3578            else !constr_dist.eq.11
3579           if (dhpb1(i).gt.0.0d0) then
3580             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3581             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3582 c            write (iout,*) "beta nmr",
3583 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3584           else !dhpb(i).gt.0.00
3585
3586 C Calculate the distance between the two points and its difference from the
3587 C target distance.
3588         dd=dist(ii,jj)
3589         rdis=dd-dhpb(i)
3590 C Get the force constant corresponding to this distance.
3591         waga=forcon(i)
3592 C Calculate the contribution to energy.
3593         ehpb=ehpb+waga*rdis*rdis
3594 C
3595 C Evaluate gradient.
3596 C
3597         fac=waga*rdis/dd
3598         endif !dhpb(i).gt.0
3599         endif
3600 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3601 cd   &   ' waga=',waga,' fac=',fac
3602         do j=1,3
3603           ggg(j)=fac*(c(j,jj)-c(j,ii))
3604         enddo
3605 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3606 C If this is a SC-SC distance, we need to calculate the contributions to the
3607 C Cartesian gradient in the SC vectors (ghpbx).
3608         if (iii.lt.ii) then
3609           do j=1,3
3610             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3611             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3612           enddo
3613         endif
3614         else !ii.gt.nres
3615 C          write(iout,*) "before"
3616           dd=dist(ii,jj)
3617 C          write(iout,*) "after",dd
3618           if (constr_dist.eq.11) then
3619             ehpb=ehpb+fordepth(i)**4.0d0
3620      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3621             fac=fordepth(i)**4.0d0
3622      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3623 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3624 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3625 C            print *,ehpb,"tu?"
3626 C            write(iout,*) ehpb,"btu?",
3627 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3628 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3629 C     &    ehpb,fordepth(i),dd
3630            else
3631           if (dhpb1(i).gt.0.0d0) then
3632             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3633             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3634 c            write (iout,*) "alph nmr",
3635 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3636           else
3637             rdis=dd-dhpb(i)
3638 C Get the force constant corresponding to this distance.
3639             waga=forcon(i)
3640 C Calculate the contribution to energy.
3641             ehpb=ehpb+waga*rdis*rdis
3642 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3643 C
3644 C Evaluate gradient.
3645 C
3646             fac=waga*rdis/dd
3647           endif
3648           endif
3649         do j=1,3
3650           ggg(j)=fac*(c(j,jj)-c(j,ii))
3651         enddo
3652 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3653 C If this is a SC-SC distance, we need to calculate the contributions to the
3654 C Cartesian gradient in the SC vectors (ghpbx).
3655         if (iii.lt.ii) then
3656           do j=1,3
3657             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3658             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3659           enddo
3660         endif
3661         do j=iii,jjj-1
3662           do k=1,3
3663             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3664           enddo
3665         enddo
3666         endif
3667       enddo
3668       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3669       return
3670       end
3671 C--------------------------------------------------------------------------
3672       subroutine ssbond_ene(i,j,eij)
3673 C
3674 C Calculate the distance and angle dependent SS-bond potential energy
3675 C using a free-energy function derived based on RHF/6-31G** ab initio
3676 C calculations of diethyl disulfide.
3677 C
3678 C A. Liwo and U. Kozlowska, 11/24/03
3679 C
3680       implicit real*8 (a-h,o-z)
3681       include 'DIMENSIONS'
3682       include 'sizesclu.dat'
3683       include 'COMMON.SBRIDGE'
3684       include 'COMMON.CHAIN'
3685       include 'COMMON.DERIV'
3686       include 'COMMON.LOCAL'
3687       include 'COMMON.INTERACT'
3688       include 'COMMON.VAR'
3689       include 'COMMON.IOUNITS'
3690       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3691       itypi=iabs(itype(i))
3692       xi=c(1,nres+i)
3693       yi=c(2,nres+i)
3694       zi=c(3,nres+i)
3695       dxi=dc_norm(1,nres+i)
3696       dyi=dc_norm(2,nres+i)
3697       dzi=dc_norm(3,nres+i)
3698       dsci_inv=dsc_inv(itypi)
3699       itypj=iabs(itype(j))
3700       dscj_inv=dsc_inv(itypj)
3701       xj=c(1,nres+j)-xi
3702       yj=c(2,nres+j)-yi
3703       zj=c(3,nres+j)-zi
3704       dxj=dc_norm(1,nres+j)
3705       dyj=dc_norm(2,nres+j)
3706       dzj=dc_norm(3,nres+j)
3707       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3708       rij=dsqrt(rrij)
3709       erij(1)=xj*rij
3710       erij(2)=yj*rij
3711       erij(3)=zj*rij
3712       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3713       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3714       om12=dxi*dxj+dyi*dyj+dzi*dzj
3715       do k=1,3
3716         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3717         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3718       enddo
3719       rij=1.0d0/rij
3720       deltad=rij-d0cm
3721       deltat1=1.0d0-om1
3722       deltat2=1.0d0+om2
3723       deltat12=om2-om1+2.0d0
3724       cosphi=om12-om1*om2
3725       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3726      &  +akct*deltad*deltat12
3727      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3728 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3729 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3730 c     &  " deltat12",deltat12," eij",eij
3731       ed=2*akcm*deltad+akct*deltat12
3732       pom1=akct*deltad
3733       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3734       eom1=-2*akth*deltat1-pom1-om2*pom2
3735       eom2= 2*akth*deltat2+pom1-om1*pom2
3736       eom12=pom2
3737       do k=1,3
3738         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3739       enddo
3740       do k=1,3
3741         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3742      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3743         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3744      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3745       enddo
3746 C
3747 C Calculate the components of the gradient in DC and X
3748 C
3749       do k=i,j-1
3750         do l=1,3
3751           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3752         enddo
3753       enddo
3754       return
3755       end
3756 C--------------------------------------------------------------------------
3757       subroutine ebond(estr)
3758 c
3759 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3760 c
3761       implicit real*8 (a-h,o-z)
3762       include 'DIMENSIONS'
3763       include 'sizesclu.dat'
3764       include 'COMMON.LOCAL'
3765       include 'COMMON.GEO'
3766       include 'COMMON.INTERACT'
3767       include 'COMMON.DERIV'
3768       include 'COMMON.VAR'
3769       include 'COMMON.CHAIN'
3770       include 'COMMON.IOUNITS'
3771       include 'COMMON.NAMES'
3772       include 'COMMON.FFIELD'
3773       include 'COMMON.CONTROL'
3774       logical energy_dec /.false./
3775       double precision u(3),ud(3)
3776       estr=0.0d0
3777       estr1=0.0d0
3778       do i=nnt+1,nct
3779         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3780 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3781 C          do j=1,3
3782 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3783 C     &      *dc(j,i-1)/vbld(i)
3784 C          enddo
3785 C          if (energy_dec) write(iout,*)
3786 C     &       "estr1",i,vbld(i),distchainmax,
3787 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3788 C        else
3789          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3790         diff = vbld(i)-vbldpDUM
3791          else
3792           diff = vbld(i)-vbldp0
3793 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3794          endif
3795           estr=estr+diff*diff
3796           do j=1,3
3797             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3798           enddo
3799 C        endif
3800 C        write (iout,'(a7,i5,4f7.3)')
3801 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3802       enddo
3803       estr=0.5d0*AKP*estr+estr1
3804 c
3805 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3806 c
3807       do i=nnt,nct
3808         iti=iabs(itype(i))
3809         if (iti.ne.10 .and. iti.ne.ntyp1) then
3810           nbi=nbondterm(iti)
3811           if (nbi.eq.1) then
3812             diff=vbld(i+nres)-vbldsc0(1,iti)
3813 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3814 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3815             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3816             do j=1,3
3817               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3818             enddo
3819           else
3820             do j=1,nbi
3821               diff=vbld(i+nres)-vbldsc0(j,iti)
3822               ud(j)=aksc(j,iti)*diff
3823               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3824             enddo
3825             uprod=u(1)
3826             do j=2,nbi
3827               uprod=uprod*u(j)
3828             enddo
3829             usum=0.0d0
3830             usumsqder=0.0d0
3831             do j=1,nbi
3832               uprod1=1.0d0
3833               uprod2=1.0d0
3834               do k=1,nbi
3835                 if (k.ne.j) then
3836                   uprod1=uprod1*u(k)
3837                   uprod2=uprod2*u(k)*u(k)
3838                 endif
3839               enddo
3840               usum=usum+uprod1
3841               usumsqder=usumsqder+ud(j)*uprod2
3842             enddo
3843 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3844 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3845             estr=estr+uprod/usum
3846             do j=1,3
3847              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3848             enddo
3849           endif
3850         endif
3851       enddo
3852       return
3853       end
3854 #ifdef CRYST_THETA
3855 C--------------------------------------------------------------------------
3856       subroutine ebend(etheta,ethetacnstr)
3857 C
3858 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3859 C angles gamma and its derivatives in consecutive thetas and gammas.
3860 C
3861       implicit real*8 (a-h,o-z)
3862       include 'DIMENSIONS'
3863       include 'sizesclu.dat'
3864       include 'COMMON.LOCAL'
3865       include 'COMMON.GEO'
3866       include 'COMMON.INTERACT'
3867       include 'COMMON.DERIV'
3868       include 'COMMON.VAR'
3869       include 'COMMON.CHAIN'
3870       include 'COMMON.IOUNITS'
3871       include 'COMMON.NAMES'
3872       include 'COMMON.FFIELD'
3873       include 'COMMON.TORCNSTR'
3874       common /calcthet/ term1,term2,termm,diffak,ratak,
3875      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3876      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3877       double precision y(2),z(2)
3878       delta=0.02d0*pi
3879 c      time11=dexp(-2*time)
3880 c      time12=1.0d0
3881       etheta=0.0D0
3882 c      write (iout,*) "nres",nres
3883 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3884 c      write (iout,*) ithet_start,ithet_end
3885       do i=ithet_start,ithet_end
3886         if (i.le.2) cycle
3887         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3888      &  .or.itype(i).eq.ntyp1) cycle
3889 C Zero the energy function and its derivative at 0 or pi.
3890         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3891         it=itype(i-1)
3892         ichir1=isign(1,itype(i-2))
3893         ichir2=isign(1,itype(i))
3894          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3895          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3896          if (itype(i-1).eq.10) then
3897           itype1=isign(10,itype(i-2))
3898           ichir11=isign(1,itype(i-2))
3899           ichir12=isign(1,itype(i-2))
3900           itype2=isign(10,itype(i))
3901           ichir21=isign(1,itype(i))
3902           ichir22=isign(1,itype(i))
3903          endif
3904          if (i.eq.3) then
3905           y(1)=0.0D0
3906           y(2)=0.0D0
3907           else
3908         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3909 #ifdef OSF
3910           phii=phi(i)
3911 c          icrc=0
3912 c          call proc_proc(phii,icrc)
3913           if (icrc.eq.1) phii=150.0
3914 #else
3915           phii=phi(i)
3916 #endif
3917           y(1)=dcos(phii)
3918           y(2)=dsin(phii)
3919         else
3920           y(1)=0.0D0
3921           y(2)=0.0D0
3922         endif
3923         endif
3924         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3925 #ifdef OSF
3926           phii1=phi(i+1)
3927 c          icrc=0
3928 c          call proc_proc(phii1,icrc)
3929           if (icrc.eq.1) phii1=150.0
3930           phii1=pinorm(phii1)
3931           z(1)=cos(phii1)
3932 #else
3933           phii1=phi(i+1)
3934           z(1)=dcos(phii1)
3935 #endif
3936           z(2)=dsin(phii1)
3937         else
3938           z(1)=0.0D0
3939           z(2)=0.0D0
3940         endif
3941 C Calculate the "mean" value of theta from the part of the distribution
3942 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3943 C In following comments this theta will be referred to as t_c.
3944         thet_pred_mean=0.0d0
3945         do k=1,2
3946             athetk=athet(k,it,ichir1,ichir2)
3947             bthetk=bthet(k,it,ichir1,ichir2)
3948           if (it.eq.10) then
3949              athetk=athet(k,itype1,ichir11,ichir12)
3950              bthetk=bthet(k,itype2,ichir21,ichir22)
3951           endif
3952           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3953         enddo
3954 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3955         dthett=thet_pred_mean*ssd
3956         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3957 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3958 C Derivatives of the "mean" values in gamma1 and gamma2.
3959         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3960      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3961          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3962      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3963          if (it.eq.10) then
3964       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3965      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3966         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3967      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3968          endif
3969         if (theta(i).gt.pi-delta) then
3970           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3971      &         E_tc0)
3972           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3973           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3974           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3975      &        E_theta)
3976           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3977      &        E_tc)
3978         else if (theta(i).lt.delta) then
3979           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3980           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3981           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3982      &        E_theta)
3983           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3984           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3985      &        E_tc)
3986         else
3987           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3988      &        E_theta,E_tc)
3989         endif
3990         etheta=etheta+ethetai
3991 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3992 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3993         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3994         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3995         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3996 c 1215   continue
3997       enddo
3998 C Ufff.... We've done all this!!!
3999 C now constrains
4000       ethetacnstr=0.0d0
4001 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4002       do i=1,ntheta_constr
4003         itheta=itheta_constr(i)
4004         thetiii=theta(itheta)
4005         difi=pinorm(thetiii-theta_constr0(i))
4006         if (difi.gt.theta_drange(i)) then
4007           difi=difi-theta_drange(i)
4008           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4009           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4010      &    +for_thet_constr(i)*difi**3
4011         else if (difi.lt.-drange(i)) then
4012           difi=difi+drange(i)
4013           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4014           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4015      &    +for_thet_constr(i)*difi**3
4016         else
4017           difi=0.0
4018         endif
4019 C       if (energy_dec) then
4020 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4021 C     &    i,itheta,rad2deg*thetiii,
4022 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4023 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4024 C     &    gloc(itheta+nphi-2,icg)
4025 C        endif
4026       enddo
4027       return
4028       end
4029 C---------------------------------------------------------------------------
4030       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4031      &     E_tc)
4032       implicit real*8 (a-h,o-z)
4033       include 'DIMENSIONS'
4034       include 'COMMON.LOCAL'
4035       include 'COMMON.IOUNITS'
4036       common /calcthet/ term1,term2,termm,diffak,ratak,
4037      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4038      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4039 C Calculate the contributions to both Gaussian lobes.
4040 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4041 C The "polynomial part" of the "standard deviation" of this part of
4042 C the distribution.
4043         sig=polthet(3,it)
4044         do j=2,0,-1
4045           sig=sig*thet_pred_mean+polthet(j,it)
4046         enddo
4047 C Derivative of the "interior part" of the "standard deviation of the"
4048 C gamma-dependent Gaussian lobe in t_c.
4049         sigtc=3*polthet(3,it)
4050         do j=2,1,-1
4051           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4052         enddo
4053         sigtc=sig*sigtc
4054 C Set the parameters of both Gaussian lobes of the distribution.
4055 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4056         fac=sig*sig+sigc0(it)
4057         sigcsq=fac+fac
4058         sigc=1.0D0/sigcsq
4059 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4060         sigsqtc=-4.0D0*sigcsq*sigtc
4061 c       print *,i,sig,sigtc,sigsqtc
4062 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4063         sigtc=-sigtc/(fac*fac)
4064 C Following variable is sigma(t_c)**(-2)
4065         sigcsq=sigcsq*sigcsq
4066         sig0i=sig0(it)
4067         sig0inv=1.0D0/sig0i**2
4068         delthec=thetai-thet_pred_mean
4069         delthe0=thetai-theta0i
4070         term1=-0.5D0*sigcsq*delthec*delthec
4071         term2=-0.5D0*sig0inv*delthe0*delthe0
4072 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4073 C NaNs in taking the logarithm. We extract the largest exponent which is added
4074 C to the energy (this being the log of the distribution) at the end of energy
4075 C term evaluation for this virtual-bond angle.
4076         if (term1.gt.term2) then
4077           termm=term1
4078           term2=dexp(term2-termm)
4079           term1=1.0d0
4080         else
4081           termm=term2
4082           term1=dexp(term1-termm)
4083           term2=1.0d0
4084         endif
4085 C The ratio between the gamma-independent and gamma-dependent lobes of
4086 C the distribution is a Gaussian function of thet_pred_mean too.
4087         diffak=gthet(2,it)-thet_pred_mean
4088         ratak=diffak/gthet(3,it)**2
4089         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4090 C Let's differentiate it in thet_pred_mean NOW.
4091         aktc=ak*ratak
4092 C Now put together the distribution terms to make complete distribution.
4093         termexp=term1+ak*term2
4094         termpre=sigc+ak*sig0i
4095 C Contribution of the bending energy from this theta is just the -log of
4096 C the sum of the contributions from the two lobes and the pre-exponential
4097 C factor. Simple enough, isn't it?
4098         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4099 C NOW the derivatives!!!
4100 C 6/6/97 Take into account the deformation.
4101         E_theta=(delthec*sigcsq*term1
4102      &       +ak*delthe0*sig0inv*term2)/termexp
4103         E_tc=((sigtc+aktc*sig0i)/termpre
4104      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4105      &       aktc*term2)/termexp)
4106       return
4107       end
4108 c-----------------------------------------------------------------------------
4109       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4110       implicit real*8 (a-h,o-z)
4111       include 'DIMENSIONS'
4112       include 'COMMON.LOCAL'
4113       include 'COMMON.IOUNITS'
4114       common /calcthet/ term1,term2,termm,diffak,ratak,
4115      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4116      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4117       delthec=thetai-thet_pred_mean
4118       delthe0=thetai-theta0i
4119 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4120       t3 = thetai-thet_pred_mean
4121       t6 = t3**2
4122       t9 = term1
4123       t12 = t3*sigcsq
4124       t14 = t12+t6*sigsqtc
4125       t16 = 1.0d0
4126       t21 = thetai-theta0i
4127       t23 = t21**2
4128       t26 = term2
4129       t27 = t21*t26
4130       t32 = termexp
4131       t40 = t32**2
4132       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4133      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4134      & *(-t12*t9-ak*sig0inv*t27)
4135       return
4136       end
4137 #else
4138 C--------------------------------------------------------------------------
4139       subroutine ebend(etheta,ethetacnstr)
4140 C
4141 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4142 C angles gamma and its derivatives in consecutive thetas and gammas.
4143 C ab initio-derived potentials from
4144 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4145 C
4146       implicit real*8 (a-h,o-z)
4147       include 'DIMENSIONS'
4148       include 'sizesclu.dat'
4149       include 'COMMON.LOCAL'
4150       include 'COMMON.GEO'
4151       include 'COMMON.INTERACT'
4152       include 'COMMON.DERIV'
4153       include 'COMMON.VAR'
4154       include 'COMMON.CHAIN'
4155       include 'COMMON.IOUNITS'
4156       include 'COMMON.NAMES'
4157       include 'COMMON.FFIELD'
4158       include 'COMMON.CONTROL'
4159       include 'COMMON.TORCNSTR'
4160       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4161      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4162      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4163      & sinph1ph2(maxdouble,maxdouble)
4164       logical lprn /.false./, lprn1 /.false./
4165       etheta=0.0D0
4166 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4167       do i=ithet_start,ithet_end
4168         if (i.le.2) cycle
4169         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4170      &  .or.itype(i).eq.ntyp1) cycle
4171 c        if (itype(i-1).eq.ntyp1) cycle
4172         if (iabs(itype(i+1)).eq.20) iblock=2
4173         if (iabs(itype(i+1)).ne.20) iblock=1
4174         dethetai=0.0d0
4175         dephii=0.0d0
4176         dephii1=0.0d0
4177         theti2=0.5d0*theta(i)
4178         ityp2=ithetyp((itype(i-1)))
4179         do k=1,nntheterm
4180           coskt(k)=dcos(k*theti2)
4181           sinkt(k)=dsin(k*theti2)
4182         enddo
4183         if (i.eq.3) then
4184           phii=0.0d0
4185           ityp1=nthetyp+1
4186           do k=1,nsingle
4187             cosph1(k)=0.0d0
4188             sinph1(k)=0.0d0
4189           enddo
4190         else
4191         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4192 #ifdef OSF
4193           phii=phi(i)
4194           if (phii.ne.phii) phii=150.0
4195 #else
4196           phii=phi(i)
4197 #endif
4198           ityp1=ithetyp((itype(i-2)))
4199           do k=1,nsingle
4200             cosph1(k)=dcos(k*phii)
4201             sinph1(k)=dsin(k*phii)
4202           enddo
4203         else
4204           phii=0.0d0
4205 c          ityp1=nthetyp+1
4206           do k=1,nsingle
4207             ityp1=ithetyp((itype(i-2)))
4208             cosph1(k)=0.0d0
4209             sinph1(k)=0.0d0
4210           enddo
4211         endif
4212         endif
4213         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4214 #ifdef OSF
4215           phii1=phi(i+1)
4216           if (phii1.ne.phii1) phii1=150.0
4217           phii1=pinorm(phii1)
4218 #else
4219           phii1=phi(i+1)
4220 #endif
4221           ityp3=ithetyp((itype(i)))
4222           do k=1,nsingle
4223             cosph2(k)=dcos(k*phii1)
4224             sinph2(k)=dsin(k*phii1)
4225           enddo
4226         else
4227           phii1=0.0d0
4228 c          ityp3=nthetyp+1
4229           ityp3=ithetyp((itype(i)))
4230           do k=1,nsingle
4231             cosph2(k)=0.0d0
4232             sinph2(k)=0.0d0
4233           enddo
4234         endif
4235 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4236 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4237 c        call flush(iout)
4238         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4239         do k=1,ndouble
4240           do l=1,k-1
4241             ccl=cosph1(l)*cosph2(k-l)
4242             ssl=sinph1(l)*sinph2(k-l)
4243             scl=sinph1(l)*cosph2(k-l)
4244             csl=cosph1(l)*sinph2(k-l)
4245             cosph1ph2(l,k)=ccl-ssl
4246             cosph1ph2(k,l)=ccl+ssl
4247             sinph1ph2(l,k)=scl+csl
4248             sinph1ph2(k,l)=scl-csl
4249           enddo
4250         enddo
4251         if (lprn) then
4252         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4253      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4254         write (iout,*) "coskt and sinkt"
4255         do k=1,nntheterm
4256           write (iout,*) k,coskt(k),sinkt(k)
4257         enddo
4258         endif
4259         do k=1,ntheterm
4260           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4261           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4262      &      *coskt(k)
4263           if (lprn)
4264      &    write (iout,*) "k",k," aathet",
4265      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4266      &     " ethetai",ethetai
4267         enddo
4268         if (lprn) then
4269         write (iout,*) "cosph and sinph"
4270         do k=1,nsingle
4271           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4272         enddo
4273         write (iout,*) "cosph1ph2 and sinph2ph2"
4274         do k=2,ndouble
4275           do l=1,k-1
4276             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4277      &         sinph1ph2(l,k),sinph1ph2(k,l)
4278           enddo
4279         enddo
4280         write(iout,*) "ethetai",ethetai
4281         endif
4282         do m=1,ntheterm2
4283           do k=1,nsingle
4284             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4285      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4286      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4287      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4288             ethetai=ethetai+sinkt(m)*aux
4289             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4290             dephii=dephii+k*sinkt(m)*(
4291      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4292      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4293             dephii1=dephii1+k*sinkt(m)*(
4294      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4295      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4296             if (lprn)
4297      &      write (iout,*) "m",m," k",k," bbthet",
4298      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4299      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4300      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4301      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4302           enddo
4303         enddo
4304         if (lprn)
4305      &  write(iout,*) "ethetai",ethetai
4306         do m=1,ntheterm3
4307           do k=2,ndouble
4308             do l=1,k-1
4309               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4310      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4311      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4312      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4313               ethetai=ethetai+sinkt(m)*aux
4314               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4315               dephii=dephii+l*sinkt(m)*(
4316      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4317      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4318      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4319      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4320               dephii1=dephii1+(k-l)*sinkt(m)*(
4321      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4322      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4323      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4324      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4325               if (lprn) then
4326               write (iout,*) "m",m," k",k," l",l," ffthet",
4327      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4328      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4329      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4330      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4331      &            " ethetai",ethetai
4332               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4333      &            cosph1ph2(k,l)*sinkt(m),
4334      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4335               endif
4336             enddo
4337           enddo
4338         enddo
4339 10      continue
4340         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4341      &   i,theta(i)*rad2deg,phii*rad2deg,
4342      &   phii1*rad2deg,ethetai
4343         etheta=etheta+ethetai
4344         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4345         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4346 c        gloc(nphi+i-2,icg)=wang*dethetai
4347         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4348       enddo
4349 C now constrains
4350       ethetacnstr=0.0d0
4351 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4352       do i=1,ntheta_constr
4353         itheta=itheta_constr(i)
4354         thetiii=theta(itheta)
4355         difi=pinorm(thetiii-theta_constr0(i))
4356         if (difi.gt.theta_drange(i)) then
4357           difi=difi-theta_drange(i)
4358           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4359           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4360      &    +for_thet_constr(i)*difi**3
4361         else if (difi.lt.-drange(i)) then
4362           difi=difi+drange(i)
4363           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4364           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4365      &    +for_thet_constr(i)*difi**3
4366         else
4367           difi=0.0
4368         endif
4369 C       if (energy_dec) then
4370 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4371 C     &    i,itheta,rad2deg*thetiii,
4372 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4373 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4374 C     &    gloc(itheta+nphi-2,icg)
4375 C        endif
4376       enddo
4377       return
4378       end
4379 #endif
4380 #ifdef CRYST_SC
4381 c-----------------------------------------------------------------------------
4382       subroutine esc(escloc)
4383 C Calculate the local energy of a side chain and its derivatives in the
4384 C corresponding virtual-bond valence angles THETA and the spherical angles
4385 C ALPHA and OMEGA.
4386       implicit real*8 (a-h,o-z)
4387       include 'DIMENSIONS'
4388       include 'sizesclu.dat'
4389       include 'COMMON.GEO'
4390       include 'COMMON.LOCAL'
4391       include 'COMMON.VAR'
4392       include 'COMMON.INTERACT'
4393       include 'COMMON.DERIV'
4394       include 'COMMON.CHAIN'
4395       include 'COMMON.IOUNITS'
4396       include 'COMMON.NAMES'
4397       include 'COMMON.FFIELD'
4398       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4399      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4400       common /sccalc/ time11,time12,time112,theti,it,nlobit
4401       delta=0.02d0*pi
4402       escloc=0.0D0
4403 c     write (iout,'(a)') 'ESC'
4404       do i=loc_start,loc_end
4405         it=itype(i)
4406         if (it.eq.ntyp1) cycle
4407         if (it.eq.10) goto 1
4408         nlobit=nlob(iabs(it))
4409 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4410 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4411         theti=theta(i+1)-pipol
4412         x(1)=dtan(theti)
4413         x(2)=alph(i)
4414         x(3)=omeg(i)
4415 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4416
4417         if (x(2).gt.pi-delta) then
4418           xtemp(1)=x(1)
4419           xtemp(2)=pi-delta
4420           xtemp(3)=x(3)
4421           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4422           xtemp(2)=pi
4423           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4424           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4425      &        escloci,dersc(2))
4426           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4427      &        ddersc0(1),dersc(1))
4428           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4429      &        ddersc0(3),dersc(3))
4430           xtemp(2)=pi-delta
4431           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4432           xtemp(2)=pi
4433           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4434           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4435      &            dersc0(2),esclocbi,dersc02)
4436           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4437      &            dersc12,dersc01)
4438           call splinthet(x(2),0.5d0*delta,ss,ssd)
4439           dersc0(1)=dersc01
4440           dersc0(2)=dersc02
4441           dersc0(3)=0.0d0
4442           do k=1,3
4443             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4444           enddo
4445           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4446 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4447 c    &             esclocbi,ss,ssd
4448           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4449 c         escloci=esclocbi
4450 c         write (iout,*) escloci
4451         else if (x(2).lt.delta) then
4452           xtemp(1)=x(1)
4453           xtemp(2)=delta
4454           xtemp(3)=x(3)
4455           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4456           xtemp(2)=0.0d0
4457           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4458           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4459      &        escloci,dersc(2))
4460           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4461      &        ddersc0(1),dersc(1))
4462           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4463      &        ddersc0(3),dersc(3))
4464           xtemp(2)=delta
4465           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4466           xtemp(2)=0.0d0
4467           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4468           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4469      &            dersc0(2),esclocbi,dersc02)
4470           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4471      &            dersc12,dersc01)
4472           dersc0(1)=dersc01
4473           dersc0(2)=dersc02
4474           dersc0(3)=0.0d0
4475           call splinthet(x(2),0.5d0*delta,ss,ssd)
4476           do k=1,3
4477             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4478           enddo
4479           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4480 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4481 c    &             esclocbi,ss,ssd
4482           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4483 c         write (iout,*) escloci
4484         else
4485           call enesc(x,escloci,dersc,ddummy,.false.)
4486         endif
4487
4488         escloc=escloc+escloci
4489 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4490
4491         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4492      &   wscloc*dersc(1)
4493         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4494         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4495     1   continue
4496       enddo
4497       return
4498       end
4499 C---------------------------------------------------------------------------
4500       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4501       implicit real*8 (a-h,o-z)
4502       include 'DIMENSIONS'
4503       include 'COMMON.GEO'
4504       include 'COMMON.LOCAL'
4505       include 'COMMON.IOUNITS'
4506       common /sccalc/ time11,time12,time112,theti,it,nlobit
4507       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4508       double precision contr(maxlob,-1:1)
4509       logical mixed
4510 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4511         escloc_i=0.0D0
4512         do j=1,3
4513           dersc(j)=0.0D0
4514           if (mixed) ddersc(j)=0.0d0
4515         enddo
4516         x3=x(3)
4517
4518 C Because of periodicity of the dependence of the SC energy in omega we have
4519 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4520 C To avoid underflows, first compute & store the exponents.
4521
4522         do iii=-1,1
4523
4524           x(3)=x3+iii*dwapi
4525
4526           do j=1,nlobit
4527             do k=1,3
4528               z(k)=x(k)-censc(k,j,it)
4529             enddo
4530             do k=1,3
4531               Axk=0.0D0
4532               do l=1,3
4533                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4534               enddo
4535               Ax(k,j,iii)=Axk
4536             enddo
4537             expfac=0.0D0
4538             do k=1,3
4539               expfac=expfac+Ax(k,j,iii)*z(k)
4540             enddo
4541             contr(j,iii)=expfac
4542           enddo ! j
4543
4544         enddo ! iii
4545
4546         x(3)=x3
4547 C As in the case of ebend, we want to avoid underflows in exponentiation and
4548 C subsequent NaNs and INFs in energy calculation.
4549 C Find the largest exponent
4550         emin=contr(1,-1)
4551         do iii=-1,1
4552           do j=1,nlobit
4553             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4554           enddo
4555         enddo
4556         emin=0.5D0*emin
4557 cd      print *,'it=',it,' emin=',emin
4558
4559 C Compute the contribution to SC energy and derivatives
4560         do iii=-1,1
4561
4562           do j=1,nlobit
4563             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4564 cd          print *,'j=',j,' expfac=',expfac
4565             escloc_i=escloc_i+expfac
4566             do k=1,3
4567               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4568             enddo
4569             if (mixed) then
4570               do k=1,3,2
4571                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4572      &            +gaussc(k,2,j,it))*expfac
4573               enddo
4574             endif
4575           enddo
4576
4577         enddo ! iii
4578
4579         dersc(1)=dersc(1)/cos(theti)**2
4580         ddersc(1)=ddersc(1)/cos(theti)**2
4581         ddersc(3)=ddersc(3)
4582
4583         escloci=-(dlog(escloc_i)-emin)
4584         do j=1,3
4585           dersc(j)=dersc(j)/escloc_i
4586         enddo
4587         if (mixed) then
4588           do j=1,3,2
4589             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4590           enddo
4591         endif
4592       return
4593       end
4594 C------------------------------------------------------------------------------
4595       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4596       implicit real*8 (a-h,o-z)
4597       include 'DIMENSIONS'
4598       include 'COMMON.GEO'
4599       include 'COMMON.LOCAL'
4600       include 'COMMON.IOUNITS'
4601       common /sccalc/ time11,time12,time112,theti,it,nlobit
4602       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4603       double precision contr(maxlob)
4604       logical mixed
4605
4606       escloc_i=0.0D0
4607
4608       do j=1,3
4609         dersc(j)=0.0D0
4610       enddo
4611
4612       do j=1,nlobit
4613         do k=1,2
4614           z(k)=x(k)-censc(k,j,it)
4615         enddo
4616         z(3)=dwapi
4617         do k=1,3
4618           Axk=0.0D0
4619           do l=1,3
4620             Axk=Axk+gaussc(l,k,j,it)*z(l)
4621           enddo
4622           Ax(k,j)=Axk
4623         enddo
4624         expfac=0.0D0
4625         do k=1,3
4626           expfac=expfac+Ax(k,j)*z(k)
4627         enddo
4628         contr(j)=expfac
4629       enddo ! j
4630
4631 C As in the case of ebend, we want to avoid underflows in exponentiation and
4632 C subsequent NaNs and INFs in energy calculation.
4633 C Find the largest exponent
4634       emin=contr(1)
4635       do j=1,nlobit
4636         if (emin.gt.contr(j)) emin=contr(j)
4637       enddo
4638       emin=0.5D0*emin
4639
4640 C Compute the contribution to SC energy and derivatives
4641
4642       dersc12=0.0d0
4643       do j=1,nlobit
4644         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4645         escloc_i=escloc_i+expfac
4646         do k=1,2
4647           dersc(k)=dersc(k)+Ax(k,j)*expfac
4648         enddo
4649         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4650      &            +gaussc(1,2,j,it))*expfac
4651         dersc(3)=0.0d0
4652       enddo
4653
4654       dersc(1)=dersc(1)/cos(theti)**2
4655       dersc12=dersc12/cos(theti)**2
4656       escloci=-(dlog(escloc_i)-emin)
4657       do j=1,2
4658         dersc(j)=dersc(j)/escloc_i
4659       enddo
4660       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4661       return
4662       end
4663 #else
4664 c----------------------------------------------------------------------------------
4665       subroutine esc(escloc)
4666 C Calculate the local energy of a side chain and its derivatives in the
4667 C corresponding virtual-bond valence angles THETA and the spherical angles
4668 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4669 C added by Urszula Kozlowska. 07/11/2007
4670 C
4671       implicit real*8 (a-h,o-z)
4672       include 'DIMENSIONS'
4673       include 'sizesclu.dat'
4674       include 'COMMON.GEO'
4675       include 'COMMON.LOCAL'
4676       include 'COMMON.VAR'
4677       include 'COMMON.SCROT'
4678       include 'COMMON.INTERACT'
4679       include 'COMMON.DERIV'
4680       include 'COMMON.CHAIN'
4681       include 'COMMON.IOUNITS'
4682       include 'COMMON.NAMES'
4683       include 'COMMON.FFIELD'
4684       include 'COMMON.CONTROL'
4685       include 'COMMON.VECTORS'
4686       double precision x_prime(3),y_prime(3),z_prime(3)
4687      &    , sumene,dsc_i,dp2_i,x(65),
4688      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4689      &    de_dxx,de_dyy,de_dzz,de_dt
4690       double precision s1_t,s1_6_t,s2_t,s2_6_t
4691       double precision
4692      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4693      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4694      & dt_dCi(3),dt_dCi1(3)
4695       common /sccalc/ time11,time12,time112,theti,it,nlobit
4696       delta=0.02d0*pi
4697       escloc=0.0D0
4698       do i=loc_start,loc_end
4699         if (itype(i).eq.ntyp1) cycle
4700         costtab(i+1) =dcos(theta(i+1))
4701         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4702         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4703         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4704         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4705         cosfac=dsqrt(cosfac2)
4706         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4707         sinfac=dsqrt(sinfac2)
4708         it=iabs(itype(i))
4709         if (it.eq.10) goto 1
4710 c
4711 C  Compute the axes of tghe local cartesian coordinates system; store in
4712 c   x_prime, y_prime and z_prime
4713 c
4714         do j=1,3
4715           x_prime(j) = 0.00
4716           y_prime(j) = 0.00
4717           z_prime(j) = 0.00
4718         enddo
4719 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4720 C     &   dc_norm(3,i+nres)
4721         do j = 1,3
4722           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4723           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4724         enddo
4725         do j = 1,3
4726           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4727         enddo
4728 c       write (2,*) "i",i
4729 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4730 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4731 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4732 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4733 c      & " xy",scalar(x_prime(1),y_prime(1)),
4734 c      & " xz",scalar(x_prime(1),z_prime(1)),
4735 c      & " yy",scalar(y_prime(1),y_prime(1)),
4736 c      & " yz",scalar(y_prime(1),z_prime(1)),
4737 c      & " zz",scalar(z_prime(1),z_prime(1))
4738 c
4739 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4740 C to local coordinate system. Store in xx, yy, zz.
4741 c
4742         xx=0.0d0
4743         yy=0.0d0
4744         zz=0.0d0
4745         do j = 1,3
4746           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4747           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4748           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4749         enddo
4750
4751         xxtab(i)=xx
4752         yytab(i)=yy
4753         zztab(i)=zz
4754 C
4755 C Compute the energy of the ith side cbain
4756 C
4757 c        write (2,*) "xx",xx," yy",yy," zz",zz
4758         it=iabs(itype(i))
4759         do j = 1,65
4760           x(j) = sc_parmin(j,it)
4761         enddo
4762 #ifdef CHECK_COORD
4763 Cc diagnostics - remove later
4764         xx1 = dcos(alph(2))
4765         yy1 = dsin(alph(2))*dcos(omeg(2))
4766 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4767         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4768         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4769      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4770      &    xx1,yy1,zz1
4771 C,"  --- ", xx_w,yy_w,zz_w
4772 c end diagnostics
4773 #endif
4774         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4775      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4776      &   + x(10)*yy*zz
4777         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4778      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4779      & + x(20)*yy*zz
4780         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4781      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4782      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4783      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4784      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4785      &  +x(40)*xx*yy*zz
4786         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4787      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4788      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4789      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4790      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4791      &  +x(60)*xx*yy*zz
4792         dsc_i   = 0.743d0+x(61)
4793         dp2_i   = 1.9d0+x(62)
4794         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4795      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4796         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4797      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4798         s1=(1+x(63))/(0.1d0 + dscp1)
4799         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4800         s2=(1+x(65))/(0.1d0 + dscp2)
4801         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4802         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4803      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4804 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4805 c     &   sumene4,
4806 c     &   dscp1,dscp2,sumene
4807 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4808         escloc = escloc + sumene
4809 c        write (2,*) "escloc",escloc
4810         if (.not. calc_grad) goto 1
4811 #ifdef DEBUG
4812 C
4813 C This section to check the numerical derivatives of the energy of ith side
4814 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4815 C #define DEBUG in the code to turn it on.
4816 C
4817         write (2,*) "sumene               =",sumene
4818         aincr=1.0d-7
4819         xxsave=xx
4820         xx=xx+aincr
4821         write (2,*) xx,yy,zz
4822         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4823         de_dxx_num=(sumenep-sumene)/aincr
4824         xx=xxsave
4825         write (2,*) "xx+ sumene from enesc=",sumenep
4826         yysave=yy
4827         yy=yy+aincr
4828         write (2,*) xx,yy,zz
4829         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4830         de_dyy_num=(sumenep-sumene)/aincr
4831         yy=yysave
4832         write (2,*) "yy+ sumene from enesc=",sumenep
4833         zzsave=zz
4834         zz=zz+aincr
4835         write (2,*) xx,yy,zz
4836         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4837         de_dzz_num=(sumenep-sumene)/aincr
4838         zz=zzsave
4839         write (2,*) "zz+ sumene from enesc=",sumenep
4840         costsave=cost2tab(i+1)
4841         sintsave=sint2tab(i+1)
4842         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4843         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4844         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4845         de_dt_num=(sumenep-sumene)/aincr
4846         write (2,*) " t+ sumene from enesc=",sumenep
4847         cost2tab(i+1)=costsave
4848         sint2tab(i+1)=sintsave
4849 C End of diagnostics section.
4850 #endif
4851 C
4852 C Compute the gradient of esc
4853 C
4854         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4855         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4856         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4857         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4858         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4859         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4860         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4861         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4862         pom1=(sumene3*sint2tab(i+1)+sumene1)
4863      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4864         pom2=(sumene4*cost2tab(i+1)+sumene2)
4865      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4866         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4867         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4868      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4869      &  +x(40)*yy*zz
4870         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4871         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4872      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4873      &  +x(60)*yy*zz
4874         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4875      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4876      &        +(pom1+pom2)*pom_dx
4877 #ifdef DEBUG
4878         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4879 #endif
4880 C
4881         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4882         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4883      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4884      &  +x(40)*xx*zz
4885         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4886         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4887      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4888      &  +x(59)*zz**2 +x(60)*xx*zz
4889         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4890      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4891      &        +(pom1-pom2)*pom_dy
4892 #ifdef DEBUG
4893         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4894 #endif
4895 C
4896         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4897      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4898      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4899      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4900      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4901      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4902      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4903      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4904 #ifdef DEBUG
4905         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4906 #endif
4907 C
4908         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4909      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4910      &  +pom1*pom_dt1+pom2*pom_dt2
4911 #ifdef DEBUG
4912         write(2,*), "de_dt = ", de_dt,de_dt_num
4913 #endif
4914 c
4915 C
4916        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4917        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4918        cosfac2xx=cosfac2*xx
4919        sinfac2yy=sinfac2*yy
4920        do k = 1,3
4921          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4922      &      vbld_inv(i+1)
4923          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4924      &      vbld_inv(i)
4925          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4926          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4927 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4928 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4929 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4930 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4931          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4932          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4933          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4934          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4935          dZZ_Ci1(k)=0.0d0
4936          dZZ_Ci(k)=0.0d0
4937          do j=1,3
4938            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4939      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4940            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4941      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4942          enddo
4943
4944          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4945          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4946          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4947 c
4948          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4949          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4950        enddo
4951
4952        do k=1,3
4953          dXX_Ctab(k,i)=dXX_Ci(k)
4954          dXX_C1tab(k,i)=dXX_Ci1(k)
4955          dYY_Ctab(k,i)=dYY_Ci(k)
4956          dYY_C1tab(k,i)=dYY_Ci1(k)
4957          dZZ_Ctab(k,i)=dZZ_Ci(k)
4958          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4959          dXX_XYZtab(k,i)=dXX_XYZ(k)
4960          dYY_XYZtab(k,i)=dYY_XYZ(k)
4961          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4962        enddo
4963
4964        do k = 1,3
4965 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4966 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4967 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4968 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4969 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4970 c     &    dt_dci(k)
4971 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4972 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4973          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4974      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4975          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4976      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4977          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4978      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4979        enddo
4980 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4981 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4982
4983 C to check gradient call subroutine check_grad
4984
4985     1 continue
4986       enddo
4987       return
4988       end
4989 #endif
4990 c------------------------------------------------------------------------------
4991       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4992 C
4993 C This procedure calculates two-body contact function g(rij) and its derivative:
4994 C
4995 C           eps0ij                                     !       x < -1
4996 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4997 C            0                                         !       x > 1
4998 C
4999 C where x=(rij-r0ij)/delta
5000 C
5001 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5002 C
5003       implicit none
5004       double precision rij,r0ij,eps0ij,fcont,fprimcont
5005       double precision x,x2,x4,delta
5006 c     delta=0.02D0*r0ij
5007 c      delta=0.2D0*r0ij
5008       x=(rij-r0ij)/delta
5009       if (x.lt.-1.0D0) then
5010         fcont=eps0ij
5011         fprimcont=0.0D0
5012       else if (x.le.1.0D0) then
5013         x2=x*x
5014         x4=x2*x2
5015         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5016         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5017       else
5018         fcont=0.0D0
5019         fprimcont=0.0D0
5020       endif
5021       return
5022       end
5023 c------------------------------------------------------------------------------
5024       subroutine splinthet(theti,delta,ss,ssder)
5025       implicit real*8 (a-h,o-z)
5026       include 'DIMENSIONS'
5027       include 'sizesclu.dat'
5028       include 'COMMON.VAR'
5029       include 'COMMON.GEO'
5030       thetup=pi-delta
5031       thetlow=delta
5032       if (theti.gt.pipol) then
5033         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5034       else
5035         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5036         ssder=-ssder
5037       endif
5038       return
5039       end
5040 c------------------------------------------------------------------------------
5041       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5042       implicit none
5043       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5044       double precision ksi,ksi2,ksi3,a1,a2,a3
5045       a1=fprim0*delta/(f1-f0)
5046       a2=3.0d0-2.0d0*a1
5047       a3=a1-2.0d0
5048       ksi=(x-x0)/delta
5049       ksi2=ksi*ksi
5050       ksi3=ksi2*ksi
5051       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5052       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5053       return
5054       end
5055 c------------------------------------------------------------------------------
5056       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5057       implicit none
5058       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5059       double precision ksi,ksi2,ksi3,a1,a2,a3
5060       ksi=(x-x0)/delta
5061       ksi2=ksi*ksi
5062       ksi3=ksi2*ksi
5063       a1=fprim0x*delta
5064       a2=3*(f1x-f0x)-2*fprim0x*delta
5065       a3=fprim0x*delta-2*(f1x-f0x)
5066       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5067       return
5068       end
5069 C-----------------------------------------------------------------------------
5070 #ifdef CRYST_TOR
5071 C-----------------------------------------------------------------------------
5072       subroutine etor(etors,edihcnstr,fact)
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'sizesclu.dat'
5076       include 'COMMON.VAR'
5077       include 'COMMON.GEO'
5078       include 'COMMON.LOCAL'
5079       include 'COMMON.TORSION'
5080       include 'COMMON.INTERACT'
5081       include 'COMMON.DERIV'
5082       include 'COMMON.CHAIN'
5083       include 'COMMON.NAMES'
5084       include 'COMMON.IOUNITS'
5085       include 'COMMON.FFIELD'
5086       include 'COMMON.TORCNSTR'
5087       logical lprn
5088 C Set lprn=.true. for debugging
5089       lprn=.false.
5090 c      lprn=.true.
5091       etors=0.0D0
5092       do i=iphi_start,iphi_end
5093         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5094      &      .or. itype(i).eq.ntyp1) cycle
5095         itori=itortyp(itype(i-2))
5096         itori1=itortyp(itype(i-1))
5097         phii=phi(i)
5098         gloci=0.0D0
5099 C Proline-Proline pair is a special case...
5100         if (itori.eq.3 .and. itori1.eq.3) then
5101           if (phii.gt.-dwapi3) then
5102             cosphi=dcos(3*phii)
5103             fac=1.0D0/(1.0D0-cosphi)
5104             etorsi=v1(1,3,3)*fac
5105             etorsi=etorsi+etorsi
5106             etors=etors+etorsi-v1(1,3,3)
5107             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5108           endif
5109           do j=1,3
5110             v1ij=v1(j+1,itori,itori1)
5111             v2ij=v2(j+1,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         else
5118           do j=1,nterm_old
5119             v1ij=v1(j,itori,itori1)
5120             v2ij=v2(j,itori,itori1)
5121             cosphi=dcos(j*phii)
5122             sinphi=dsin(j*phii)
5123             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5124             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5125           enddo
5126         endif
5127         if (lprn)
5128      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5129      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5130      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5131         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5132 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5133       enddo
5134 ! 6/20/98 - dihedral angle constraints
5135       edihcnstr=0.0d0
5136       do i=1,ndih_constr
5137         itori=idih_constr(i)
5138         phii=phi(itori)
5139         difi=phii-phi0(i)
5140         if (difi.gt.drange(i)) then
5141           difi=difi-drange(i)
5142           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5143           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5144         else if (difi.lt.-drange(i)) then
5145           difi=difi+drange(i)
5146           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5147           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5148         endif
5149 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5150 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5151       enddo
5152 !      write (iout,*) 'edihcnstr',edihcnstr
5153       return
5154       end
5155 c------------------------------------------------------------------------------
5156 #else
5157       subroutine etor(etors,edihcnstr,fact)
5158       implicit real*8 (a-h,o-z)
5159       include 'DIMENSIONS'
5160       include 'sizesclu.dat'
5161       include 'COMMON.VAR'
5162       include 'COMMON.GEO'
5163       include 'COMMON.LOCAL'
5164       include 'COMMON.TORSION'
5165       include 'COMMON.INTERACT'
5166       include 'COMMON.DERIV'
5167       include 'COMMON.CHAIN'
5168       include 'COMMON.NAMES'
5169       include 'COMMON.IOUNITS'
5170       include 'COMMON.FFIELD'
5171       include 'COMMON.TORCNSTR'
5172       logical lprn
5173 C Set lprn=.true. for debugging
5174       lprn=.false.
5175 c      lprn=.true.
5176       etors=0.0D0
5177       do i=iphi_start,iphi_end
5178         if (i.le.2) cycle
5179         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5180      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5181         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5182          if (iabs(itype(i)).eq.20) then
5183          iblock=2
5184          else
5185          iblock=1
5186          endif
5187         itori=itortyp(itype(i-2))
5188         itori1=itortyp(itype(i-1))
5189         phii=phi(i)
5190         gloci=0.0D0
5191 C Regular cosine and sine terms
5192         do j=1,nterm(itori,itori1,iblock)
5193           v1ij=v1(j,itori,itori1,iblock)
5194           v2ij=v2(j,itori,itori1,iblock)
5195           cosphi=dcos(j*phii)
5196           sinphi=dsin(j*phii)
5197           etors=etors+v1ij*cosphi+v2ij*sinphi
5198           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5199         enddo
5200 C Lorentz terms
5201 C                         v1
5202 C  E = SUM ----------------------------------- - v1
5203 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5204 C
5205         cosphi=dcos(0.5d0*phii)
5206         sinphi=dsin(0.5d0*phii)
5207         do j=1,nlor(itori,itori1,iblock)
5208           vl1ij=vlor1(j,itori,itori1)
5209           vl2ij=vlor2(j,itori,itori1)
5210           vl3ij=vlor3(j,itori,itori1)
5211           pom=vl2ij*cosphi+vl3ij*sinphi
5212           pom1=1.0d0/(pom*pom+1.0d0)
5213           etors=etors+vl1ij*pom1
5214           pom=-pom*pom1*pom1
5215           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5216         enddo
5217 C Subtract the constant term
5218         etors=etors-v0(itori,itori1,iblock)
5219         if (lprn)
5220      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5221      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5222      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5223         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5224 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5225  1215   continue
5226       enddo
5227 ! 6/20/98 - dihedral angle constraints
5228       edihcnstr=0.0d0
5229       do i=1,ndih_constr
5230         itori=idih_constr(i)
5231         phii=phi(itori)
5232         difi=pinorm(phii-phi0(i))
5233         edihi=0.0d0
5234         if (difi.gt.drange(i)) then
5235           difi=difi-drange(i)
5236           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5237           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5238           edihi=0.25d0*ftors(i)*difi**4
5239         else if (difi.lt.-drange(i)) then
5240           difi=difi+drange(i)
5241           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5242           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5243           edihi=0.25d0*ftors(i)*difi**4
5244         else
5245           difi=0.0d0
5246         endif
5247 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5248 c     &    drange(i),edihi
5249 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5250 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5251       enddo
5252 !      write (iout,*) 'edihcnstr',edihcnstr
5253       return
5254       end
5255 c----------------------------------------------------------------------------
5256       subroutine etor_d(etors_d,fact2)
5257 C 6/23/01 Compute double torsional energy
5258       implicit real*8 (a-h,o-z)
5259       include 'DIMENSIONS'
5260       include 'sizesclu.dat'
5261       include 'COMMON.VAR'
5262       include 'COMMON.GEO'
5263       include 'COMMON.LOCAL'
5264       include 'COMMON.TORSION'
5265       include 'COMMON.INTERACT'
5266       include 'COMMON.DERIV'
5267       include 'COMMON.CHAIN'
5268       include 'COMMON.NAMES'
5269       include 'COMMON.IOUNITS'
5270       include 'COMMON.FFIELD'
5271       include 'COMMON.TORCNSTR'
5272       logical lprn
5273 C Set lprn=.true. for debugging
5274       lprn=.false.
5275 c     lprn=.true.
5276       etors_d=0.0D0
5277       do i=iphi_start,iphi_end-1
5278         if (i.le.3) cycle
5279          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5280      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5281      &  (itype(i+1).eq.ntyp1)) cycle
5282         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5283      &     goto 1215
5284         itori=itortyp(itype(i-2))
5285         itori1=itortyp(itype(i-1))
5286         itori2=itortyp(itype(i))
5287         phii=phi(i)
5288         phii1=phi(i+1)
5289         gloci1=0.0D0
5290         gloci2=0.0D0
5291         iblock=1
5292         if (iabs(itype(i+1)).eq.20) iblock=2
5293 C Regular cosine and sine terms
5294        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5295           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5296           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5297           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5298           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5299           cosphi1=dcos(j*phii)
5300           sinphi1=dsin(j*phii)
5301           cosphi2=dcos(j*phii1)
5302           sinphi2=dsin(j*phii1)
5303           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5304      &     v2cij*cosphi2+v2sij*sinphi2
5305           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5306           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5307         enddo
5308         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5309           do l=1,k-1
5310             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5311             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5312             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5313             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5314             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5315             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5316             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5317             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5318             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5319      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5320             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5321      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5322             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5323      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5324           enddo
5325         enddo
5326         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5327         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5328  1215   continue
5329       enddo
5330       return
5331       end
5332 #endif
5333 c------------------------------------------------------------------------------
5334       subroutine eback_sc_corr(esccor)
5335 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5336 c        conformational states; temporarily implemented as differences
5337 c        between UNRES torsional potentials (dependent on three types of
5338 c        residues) and the torsional potentials dependent on all 20 types
5339 c        of residues computed from AM1 energy surfaces of terminally-blocked
5340 c        amino-acid residues.
5341       implicit real*8 (a-h,o-z)
5342       include 'DIMENSIONS'
5343       include 'sizesclu.dat'
5344       include 'COMMON.VAR'
5345       include 'COMMON.GEO'
5346       include 'COMMON.LOCAL'
5347       include 'COMMON.TORSION'
5348       include 'COMMON.SCCOR'
5349       include 'COMMON.INTERACT'
5350       include 'COMMON.DERIV'
5351       include 'COMMON.CHAIN'
5352       include 'COMMON.NAMES'
5353       include 'COMMON.IOUNITS'
5354       include 'COMMON.FFIELD'
5355       include 'COMMON.CONTROL'
5356       logical lprn
5357 C Set lprn=.true. for debugging
5358       lprn=.false.
5359 c      lprn=.true.
5360 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5361       esccor=0.0D0
5362       do i=itau_start,itau_end
5363         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5364         esccor_ii=0.0D0
5365         isccori=isccortyp(itype(i-2))
5366         isccori1=isccortyp(itype(i-1))
5367         phii=phi(i)
5368         do intertyp=1,3 !intertyp
5369 cc Added 09 May 2012 (Adasko)
5370 cc  Intertyp means interaction type of backbone mainchain correlation:
5371 c   1 = SC...Ca...Ca...Ca
5372 c   2 = Ca...Ca...Ca...SC
5373 c   3 = SC...Ca...Ca...SCi
5374         gloci=0.0D0
5375         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5376      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5377      &      (itype(i-1).eq.ntyp1)))
5378      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5379      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5380      &     .or.(itype(i).eq.ntyp1)))
5381      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5382      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5383      &      (itype(i-3).eq.ntyp1)))) cycle
5384         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5385         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5386      & cycle
5387        do j=1,nterm_sccor(isccori,isccori1)
5388           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5389           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5390           cosphi=dcos(j*tauangle(intertyp,i))
5391           sinphi=dsin(j*tauangle(intertyp,i))
5392            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5393 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5394          enddo
5395 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5396 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5397         if (lprn)
5398      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5399      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5400      &  (v1sccor(j,1,itori,itori1),j=1,6),
5401      &  (v2sccor(j,1,itori,itori1),j=1,6)
5402         gsccor_loc(i-3)=gloci
5403        enddo !intertyp
5404       enddo
5405       return
5406       end
5407 c------------------------------------------------------------------------------
5408       subroutine multibody(ecorr)
5409 C This subroutine calculates multi-body contributions to energy following
5410 C the idea of Skolnick et al. If side chains I and J make a contact and
5411 C at the same time side chains I+1 and J+1 make a contact, an extra
5412 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5413       implicit real*8 (a-h,o-z)
5414       include 'DIMENSIONS'
5415       include 'COMMON.IOUNITS'
5416       include 'COMMON.DERIV'
5417       include 'COMMON.INTERACT'
5418       include 'COMMON.CONTACTS'
5419       double precision gx(3),gx1(3)
5420       logical lprn
5421
5422 C Set lprn=.true. for debugging
5423       lprn=.false.
5424
5425       if (lprn) then
5426         write (iout,'(a)') 'Contact function values:'
5427         do i=nnt,nct-2
5428           write (iout,'(i2,20(1x,i2,f10.5))')
5429      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5430         enddo
5431       endif
5432       ecorr=0.0D0
5433       do i=nnt,nct
5434         do j=1,3
5435           gradcorr(j,i)=0.0D0
5436           gradxorr(j,i)=0.0D0
5437         enddo
5438       enddo
5439       do i=nnt,nct-2
5440
5441         DO ISHIFT = 3,4
5442
5443         i1=i+ishift
5444         num_conti=num_cont(i)
5445         num_conti1=num_cont(i1)
5446         do jj=1,num_conti
5447           j=jcont(jj,i)
5448           do kk=1,num_conti1
5449             j1=jcont(kk,i1)
5450             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5451 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5452 cd   &                   ' ishift=',ishift
5453 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5454 C The system gains extra energy.
5455               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5456             endif   ! j1==j+-ishift
5457           enddo     ! kk
5458         enddo       ! jj
5459
5460         ENDDO ! ISHIFT
5461
5462       enddo         ! i
5463       return
5464       end
5465 c------------------------------------------------------------------------------
5466       double precision function esccorr(i,j,k,l,jj,kk)
5467       implicit real*8 (a-h,o-z)
5468       include 'DIMENSIONS'
5469       include 'COMMON.IOUNITS'
5470       include 'COMMON.DERIV'
5471       include 'COMMON.INTERACT'
5472       include 'COMMON.CONTACTS'
5473       double precision gx(3),gx1(3)
5474       logical lprn
5475       lprn=.false.
5476       eij=facont(jj,i)
5477       ekl=facont(kk,k)
5478 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5479 C Calculate the multi-body contribution to energy.
5480 C Calculate multi-body contributions to the gradient.
5481 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5482 cd   & k,l,(gacont(m,kk,k),m=1,3)
5483       do m=1,3
5484         gx(m) =ekl*gacont(m,jj,i)
5485         gx1(m)=eij*gacont(m,kk,k)
5486         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5487         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5488         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5489         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5490       enddo
5491       do m=i,j-1
5492         do ll=1,3
5493           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5494         enddo
5495       enddo
5496       do m=k,l-1
5497         do ll=1,3
5498           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5499         enddo
5500       enddo
5501       esccorr=-eij*ekl
5502       return
5503       end
5504 c------------------------------------------------------------------------------
5505 #ifdef MPL
5506       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5507       implicit real*8 (a-h,o-z)
5508       include 'DIMENSIONS'
5509       integer dimen1,dimen2,atom,indx
5510       double precision buffer(dimen1,dimen2)
5511       double precision zapas
5512       common /contacts_hb/ zapas(3,20,maxres,7),
5513      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5514      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5515       num_kont=num_cont_hb(atom)
5516       do i=1,num_kont
5517         do k=1,7
5518           do j=1,3
5519             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5520           enddo ! j
5521         enddo ! k
5522         buffer(i,indx+22)=facont_hb(i,atom)
5523         buffer(i,indx+23)=ees0p(i,atom)
5524         buffer(i,indx+24)=ees0m(i,atom)
5525         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5526       enddo ! i
5527       buffer(1,indx+26)=dfloat(num_kont)
5528       return
5529       end
5530 c------------------------------------------------------------------------------
5531       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5532       implicit real*8 (a-h,o-z)
5533       include 'DIMENSIONS'
5534       integer dimen1,dimen2,atom,indx
5535       double precision buffer(dimen1,dimen2)
5536       double precision zapas
5537       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5538      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5539      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5540       num_kont=buffer(1,indx+26)
5541       num_kont_old=num_cont_hb(atom)
5542       num_cont_hb(atom)=num_kont+num_kont_old
5543       do i=1,num_kont
5544         ii=i+num_kont_old
5545         do k=1,7
5546           do j=1,3
5547             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5548           enddo ! j
5549         enddo ! k
5550         facont_hb(ii,atom)=buffer(i,indx+22)
5551         ees0p(ii,atom)=buffer(i,indx+23)
5552         ees0m(ii,atom)=buffer(i,indx+24)
5553         jcont_hb(ii,atom)=buffer(i,indx+25)
5554       enddo ! i
5555       return
5556       end
5557 c------------------------------------------------------------------------------
5558 #endif
5559       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5560 C This subroutine calculates multi-body contributions to hydrogen-bonding
5561       implicit real*8 (a-h,o-z)
5562       include 'DIMENSIONS'
5563       include 'sizesclu.dat'
5564       include 'COMMON.IOUNITS'
5565 #ifdef MPL
5566       include 'COMMON.INFO'
5567 #endif
5568       include 'COMMON.FFIELD'
5569       include 'COMMON.DERIV'
5570       include 'COMMON.INTERACT'
5571       include 'COMMON.CONTACTS'
5572 #ifdef MPL
5573       parameter (max_cont=maxconts)
5574       parameter (max_dim=2*(8*3+2))
5575       parameter (msglen1=max_cont*max_dim*4)
5576       parameter (msglen2=2*msglen1)
5577       integer source,CorrelType,CorrelID,Error
5578       double precision buffer(max_cont,max_dim)
5579 #endif
5580       double precision gx(3),gx1(3)
5581       logical lprn,ldone
5582
5583 C Set lprn=.true. for debugging
5584       lprn=.false.
5585 #ifdef MPL
5586       n_corr=0
5587       n_corr1=0
5588       if (fgProcs.le.1) goto 30
5589       if (lprn) then
5590         write (iout,'(a)') 'Contact function values:'
5591         do i=nnt,nct-2
5592           write (iout,'(2i3,50(1x,i2,f5.2))')
5593      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5594      &    j=1,num_cont_hb(i))
5595         enddo
5596       endif
5597 C Caution! Following code assumes that electrostatic interactions concerning
5598 C a given atom are split among at most two processors!
5599       CorrelType=477
5600       CorrelID=MyID+1
5601       ldone=.false.
5602       do i=1,max_cont
5603         do j=1,max_dim
5604           buffer(i,j)=0.0D0
5605         enddo
5606       enddo
5607       mm=mod(MyRank,2)
5608 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5609       if (mm) 20,20,10
5610    10 continue
5611 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5612       if (MyRank.gt.0) then
5613 C Send correlation contributions to the preceding processor
5614         msglen=msglen1
5615         nn=num_cont_hb(iatel_s)
5616         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5617 cd      write (iout,*) 'The BUFFER array:'
5618 cd      do i=1,nn
5619 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5620 cd      enddo
5621         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5622           msglen=msglen2
5623             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5624 C Clear the contacts of the atom passed to the neighboring processor
5625         nn=num_cont_hb(iatel_s+1)
5626 cd      do i=1,nn
5627 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5628 cd      enddo
5629             num_cont_hb(iatel_s)=0
5630         endif
5631 cd      write (iout,*) 'Processor ',MyID,MyRank,
5632 cd   & ' is sending correlation contribution to processor',MyID-1,
5633 cd   & ' msglen=',msglen
5634 cd      write (*,*) 'Processor ',MyID,MyRank,
5635 cd   & ' is sending correlation contribution to processor',MyID-1,
5636 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5637         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5638 cd      write (iout,*) 'Processor ',MyID,
5639 cd   & ' has sent correlation contribution to processor',MyID-1,
5640 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5641 cd      write (*,*) 'Processor ',MyID,
5642 cd   & ' has sent correlation contribution to processor',MyID-1,
5643 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5644         msglen=msglen1
5645       endif ! (MyRank.gt.0)
5646       if (ldone) goto 30
5647       ldone=.true.
5648    20 continue
5649 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5650       if (MyRank.lt.fgProcs-1) then
5651 C Receive correlation contributions from the next processor
5652         msglen=msglen1
5653         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5654 cd      write (iout,*) 'Processor',MyID,
5655 cd   & ' is receiving correlation contribution from processor',MyID+1,
5656 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5657 cd      write (*,*) 'Processor',MyID,
5658 cd   & ' is receiving correlation contribution from processor',MyID+1,
5659 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5660         nbytes=-1
5661         do while (nbytes.le.0)
5662           call mp_probe(MyID+1,CorrelType,nbytes)
5663         enddo
5664 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5665         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5666 cd      write (iout,*) 'Processor',MyID,
5667 cd   & ' has received correlation contribution from processor',MyID+1,
5668 cd   & ' msglen=',msglen,' nbytes=',nbytes
5669 cd      write (iout,*) 'The received BUFFER array:'
5670 cd      do i=1,max_cont
5671 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5672 cd      enddo
5673         if (msglen.eq.msglen1) then
5674           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5675         else if (msglen.eq.msglen2)  then
5676           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5677           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5678         else
5679           write (iout,*)
5680      & 'ERROR!!!! message length changed while processing correlations.'
5681           write (*,*)
5682      & 'ERROR!!!! message length changed while processing correlations.'
5683           call mp_stopall(Error)
5684         endif ! msglen.eq.msglen1
5685       endif ! MyRank.lt.fgProcs-1
5686       if (ldone) goto 30
5687       ldone=.true.
5688       goto 10
5689    30 continue
5690 #endif
5691       if (lprn) then
5692         write (iout,'(a)') 'Contact function values:'
5693         do i=nnt,nct-2
5694           write (iout,'(2i3,50(1x,i2,f5.2))')
5695      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5696      &    j=1,num_cont_hb(i))
5697         enddo
5698       endif
5699       ecorr=0.0D0
5700 C Remove the loop below after debugging !!!
5701       do i=nnt,nct
5702         do j=1,3
5703           gradcorr(j,i)=0.0D0
5704           gradxorr(j,i)=0.0D0
5705         enddo
5706       enddo
5707 C Calculate the local-electrostatic correlation terms
5708       do i=iatel_s,iatel_e+1
5709         i1=i+1
5710         num_conti=num_cont_hb(i)
5711         num_conti1=num_cont_hb(i+1)
5712         do jj=1,num_conti
5713           j=jcont_hb(jj,i)
5714           do kk=1,num_conti1
5715             j1=jcont_hb(kk,i1)
5716 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5717 c     &         ' jj=',jj,' kk=',kk
5718             if (j1.eq.j+1 .or. j1.eq.j-1) then
5719 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5720 C The system gains extra energy.
5721               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5722               n_corr=n_corr+1
5723             else if (j1.eq.j) then
5724 C Contacts I-J and I-(J+1) occur simultaneously.
5725 C The system loses extra energy.
5726 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5727             endif
5728           enddo ! kk
5729           do kk=1,num_conti
5730             j1=jcont_hb(kk,i)
5731 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5732 c    &         ' jj=',jj,' kk=',kk
5733             if (j1.eq.j+1) then
5734 C Contacts I-J and (I+1)-J occur simultaneously.
5735 C The system loses extra energy.
5736 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5737             endif ! j1==j+1
5738           enddo ! kk
5739         enddo ! jj
5740       enddo ! i
5741       return
5742       end
5743 c------------------------------------------------------------------------------
5744       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5745      &  n_corr1)
5746 C This subroutine calculates multi-body contributions to hydrogen-bonding
5747       implicit real*8 (a-h,o-z)
5748       include 'DIMENSIONS'
5749       include 'sizesclu.dat'
5750       include 'COMMON.IOUNITS'
5751 #ifdef MPL
5752       include 'COMMON.INFO'
5753 #endif
5754       include 'COMMON.FFIELD'
5755       include 'COMMON.DERIV'
5756       include 'COMMON.INTERACT'
5757       include 'COMMON.CONTACTS'
5758 #ifdef MPL
5759       parameter (max_cont=maxconts)
5760       parameter (max_dim=2*(8*3+2))
5761       parameter (msglen1=max_cont*max_dim*4)
5762       parameter (msglen2=2*msglen1)
5763       integer source,CorrelType,CorrelID,Error
5764       double precision buffer(max_cont,max_dim)
5765 #endif
5766       double precision gx(3),gx1(3)
5767       logical lprn,ldone
5768
5769 C Set lprn=.true. for debugging
5770       lprn=.false.
5771       eturn6=0.0d0
5772 #ifdef MPL
5773       n_corr=0
5774       n_corr1=0
5775       if (fgProcs.le.1) goto 30
5776       if (lprn) then
5777         write (iout,'(a)') 'Contact function values:'
5778         do i=nnt,nct-2
5779           write (iout,'(2i3,50(1x,i2,f5.2))')
5780      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5781      &    j=1,num_cont_hb(i))
5782         enddo
5783       endif
5784 C Caution! Following code assumes that electrostatic interactions concerning
5785 C a given atom are split among at most two processors!
5786       CorrelType=477
5787       CorrelID=MyID+1
5788       ldone=.false.
5789       do i=1,max_cont
5790         do j=1,max_dim
5791           buffer(i,j)=0.0D0
5792         enddo
5793       enddo
5794       mm=mod(MyRank,2)
5795 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5796       if (mm) 20,20,10
5797    10 continue
5798 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5799       if (MyRank.gt.0) then
5800 C Send correlation contributions to the preceding processor
5801         msglen=msglen1
5802         nn=num_cont_hb(iatel_s)
5803         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5804 cd      write (iout,*) 'The BUFFER array:'
5805 cd      do i=1,nn
5806 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5807 cd      enddo
5808         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5809           msglen=msglen2
5810             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5811 C Clear the contacts of the atom passed to the neighboring processor
5812         nn=num_cont_hb(iatel_s+1)
5813 cd      do i=1,nn
5814 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5815 cd      enddo
5816             num_cont_hb(iatel_s)=0
5817         endif
5818 cd      write (iout,*) 'Processor ',MyID,MyRank,
5819 cd   & ' is sending correlation contribution to processor',MyID-1,
5820 cd   & ' msglen=',msglen
5821 cd      write (*,*) 'Processor ',MyID,MyRank,
5822 cd   & ' is sending correlation contribution to processor',MyID-1,
5823 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5824         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5825 cd      write (iout,*) 'Processor ',MyID,
5826 cd   & ' has sent correlation contribution to processor',MyID-1,
5827 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5828 cd      write (*,*) 'Processor ',MyID,
5829 cd   & ' has sent correlation contribution to processor',MyID-1,
5830 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5831         msglen=msglen1
5832       endif ! (MyRank.gt.0)
5833       if (ldone) goto 30
5834       ldone=.true.
5835    20 continue
5836 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5837       if (MyRank.lt.fgProcs-1) then
5838 C Receive correlation contributions from the next processor
5839         msglen=msglen1
5840         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5841 cd      write (iout,*) 'Processor',MyID,
5842 cd   & ' is receiving correlation contribution from processor',MyID+1,
5843 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5844 cd      write (*,*) 'Processor',MyID,
5845 cd   & ' is receiving correlation contribution from processor',MyID+1,
5846 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5847         nbytes=-1
5848         do while (nbytes.le.0)
5849           call mp_probe(MyID+1,CorrelType,nbytes)
5850         enddo
5851 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5852         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5853 cd      write (iout,*) 'Processor',MyID,
5854 cd   & ' has received correlation contribution from processor',MyID+1,
5855 cd   & ' msglen=',msglen,' nbytes=',nbytes
5856 cd      write (iout,*) 'The received BUFFER array:'
5857 cd      do i=1,max_cont
5858 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5859 cd      enddo
5860         if (msglen.eq.msglen1) then
5861           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5862         else if (msglen.eq.msglen2)  then
5863           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5864           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5865         else
5866           write (iout,*)
5867      & 'ERROR!!!! message length changed while processing correlations.'
5868           write (*,*)
5869      & 'ERROR!!!! message length changed while processing correlations.'
5870           call mp_stopall(Error)
5871         endif ! msglen.eq.msglen1
5872       endif ! MyRank.lt.fgProcs-1
5873       if (ldone) goto 30
5874       ldone=.true.
5875       goto 10
5876    30 continue
5877 #endif
5878       if (lprn) then
5879         write (iout,'(a)') 'Contact function values:'
5880         do i=nnt,nct-2
5881           write (iout,'(2i3,50(1x,i2,f5.2))')
5882      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5883      &    j=1,num_cont_hb(i))
5884         enddo
5885       endif
5886       ecorr=0.0D0
5887       ecorr5=0.0d0
5888       ecorr6=0.0d0
5889 C Remove the loop below after debugging !!!
5890       do i=nnt,nct
5891         do j=1,3
5892           gradcorr(j,i)=0.0D0
5893           gradxorr(j,i)=0.0D0
5894         enddo
5895       enddo
5896 C Calculate the dipole-dipole interaction energies
5897       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5898       do i=iatel_s,iatel_e+1
5899         num_conti=num_cont_hb(i)
5900         do jj=1,num_conti
5901           j=jcont_hb(jj,i)
5902           call dipole(i,j,jj)
5903         enddo
5904       enddo
5905       endif
5906 C Calculate the local-electrostatic correlation terms
5907       do i=iatel_s,iatel_e+1
5908         i1=i+1
5909         num_conti=num_cont_hb(i)
5910         num_conti1=num_cont_hb(i+1)
5911         do jj=1,num_conti
5912           j=jcont_hb(jj,i)
5913           do kk=1,num_conti1
5914             j1=jcont_hb(kk,i1)
5915 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5916 c     &         ' jj=',jj,' kk=',kk
5917             if (j1.eq.j+1 .or. j1.eq.j-1) then
5918 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5919 C The system gains extra energy.
5920               n_corr=n_corr+1
5921               sqd1=dsqrt(d_cont(jj,i))
5922               sqd2=dsqrt(d_cont(kk,i1))
5923               sred_geom = sqd1*sqd2
5924               IF (sred_geom.lt.cutoff_corr) THEN
5925                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5926      &            ekont,fprimcont)
5927 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5928 c     &         ' jj=',jj,' kk=',kk
5929                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5930                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5931                 do l=1,3
5932                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5933                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5934                 enddo
5935                 n_corr1=n_corr1+1
5936 cd               write (iout,*) 'sred_geom=',sred_geom,
5937 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5938                 call calc_eello(i,j,i+1,j1,jj,kk)
5939                 if (wcorr4.gt.0.0d0)
5940      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5941                 if (wcorr5.gt.0.0d0)
5942      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5943 c                print *,"wcorr5",ecorr5
5944 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5945 cd                write(2,*)'ijkl',i,j,i+1,j1
5946                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5947      &               .or. wturn6.eq.0.0d0))then
5948 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5949                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5950 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5951 cd     &            'ecorr6=',ecorr6
5952 cd                write (iout,'(4e15.5)') sred_geom,
5953 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5954 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5955 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5956                 else if (wturn6.gt.0.0d0
5957      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5958 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5959                   eturn6=eturn6+eello_turn6(i,jj,kk)
5960 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5961                 endif
5962               ENDIF
5963 1111          continue
5964             else if (j1.eq.j) then
5965 C Contacts I-J and I-(J+1) occur simultaneously.
5966 C The system loses extra energy.
5967 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5968             endif
5969           enddo ! kk
5970           do kk=1,num_conti
5971             j1=jcont_hb(kk,i)
5972 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5973 c    &         ' jj=',jj,' kk=',kk
5974             if (j1.eq.j+1) then
5975 C Contacts I-J and (I+1)-J occur simultaneously.
5976 C The system loses extra energy.
5977 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5978             endif ! j1==j+1
5979           enddo ! kk
5980         enddo ! jj
5981       enddo ! i
5982       return
5983       end
5984 c------------------------------------------------------------------------------
5985       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'COMMON.IOUNITS'
5989       include 'COMMON.DERIV'
5990       include 'COMMON.INTERACT'
5991       include 'COMMON.CONTACTS'
5992       include 'COMMON.SHIELD'
5993
5994       double precision gx(3),gx1(3)
5995       logical lprn
5996       lprn=.false.
5997       eij=facont_hb(jj,i)
5998       ekl=facont_hb(kk,k)
5999       ees0pij=ees0p(jj,i)
6000       ees0pkl=ees0p(kk,k)
6001       ees0mij=ees0m(jj,i)
6002       ees0mkl=ees0m(kk,k)
6003       ekont=eij*ekl
6004       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6005 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6006 C Following 4 lines for diagnostics.
6007 cd    ees0pkl=0.0D0
6008 cd    ees0pij=1.0D0
6009 cd    ees0mkl=0.0D0
6010 cd    ees0mij=1.0D0
6011 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6012 c    &   ' and',k,l
6013 c     write (iout,*)'Contacts have occurred for peptide groups',
6014 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6015 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6016 C Calculate the multi-body contribution to energy.
6017       ecorr=ecorr+ekont*ees
6018       if (calc_grad) then
6019 C Calculate multi-body contributions to the gradient.
6020       do ll=1,3
6021         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6022         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6023      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6024      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6025         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6026      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6027      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6028         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6029         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6030      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6031      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6032         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6033      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6034      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6035       enddo
6036       do m=i+1,j-1
6037         do ll=1,3
6038           gradcorr(ll,m)=gradcorr(ll,m)+
6039      &     ees*ekl*gacont_hbr(ll,jj,i)-
6040      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6041      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6042         enddo
6043       enddo
6044       do m=k+1,l-1
6045         do ll=1,3
6046           gradcorr(ll,m)=gradcorr(ll,m)+
6047      &     ees*eij*gacont_hbr(ll,kk,k)-
6048      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6049      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6050         enddo
6051       enddo
6052       if (shield_mode.gt.0) then
6053        j=ees0plist(jj,i)
6054        l=ees0plist(kk,k)
6055 C        print *,i,j,fac_shield(i),fac_shield(j),
6056 C     &fac_shield(k),fac_shield(l)
6057         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6058      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6059           do ilist=1,ishield_list(i)
6060            iresshield=shield_list(ilist,i)
6061            do m=1,3
6062            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6063 C     &      *2.0
6064            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6065      &              rlocshield
6066      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6067             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6068      &+rlocshield
6069            enddo
6070           enddo
6071           do ilist=1,ishield_list(j)
6072            iresshield=shield_list(ilist,j)
6073            do m=1,3
6074            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6075 C     &     *2.0
6076            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6077      &              rlocshield
6078      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6079            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6080      &     +rlocshield
6081            enddo
6082           enddo
6083           do ilist=1,ishield_list(k)
6084            iresshield=shield_list(ilist,k)
6085            do m=1,3
6086            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6087 C     &     *2.0
6088            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6089      &              rlocshield
6090      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6091            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6092      &     +rlocshield
6093            enddo
6094           enddo
6095           do ilist=1,ishield_list(l)
6096            iresshield=shield_list(ilist,l)
6097            do m=1,3
6098            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6099 C     &     *2.0
6100            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6101      &              rlocshield
6102      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6103            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6104      &     +rlocshield
6105            enddo
6106           enddo
6107 C          print *,gshieldx(m,iresshield)
6108           do m=1,3
6109             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6110      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6111             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6112      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6113             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6114      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6115             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6116      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6117
6118             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6119      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6120             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6121      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6122             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6123      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6124             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6125      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6126
6127            enddo
6128       endif
6129       endif
6130       endif
6131       ehbcorr=ekont*ees
6132       return
6133       end
6134 C---------------------------------------------------------------------------
6135       subroutine dipole(i,j,jj)
6136       implicit real*8 (a-h,o-z)
6137       include 'DIMENSIONS'
6138       include 'sizesclu.dat'
6139       include 'COMMON.IOUNITS'
6140       include 'COMMON.CHAIN'
6141       include 'COMMON.FFIELD'
6142       include 'COMMON.DERIV'
6143       include 'COMMON.INTERACT'
6144       include 'COMMON.CONTACTS'
6145       include 'COMMON.TORSION'
6146       include 'COMMON.VAR'
6147       include 'COMMON.GEO'
6148       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6149      &  auxmat(2,2)
6150       iti1 = itortyp(itype(i+1))
6151       if (j.lt.nres-1) then
6152         if (itype(j).le.ntyp) then
6153           itj1 = itortyp(itype(j+1))
6154         else
6155           itj1=ntortyp+1
6156         endif
6157       else
6158         itj1=ntortyp+1
6159       endif
6160       do iii=1,2
6161         dipi(iii,1)=Ub2(iii,i)
6162         dipderi(iii)=Ub2der(iii,i)
6163         dipi(iii,2)=b1(iii,iti1)
6164         dipj(iii,1)=Ub2(iii,j)
6165         dipderj(iii)=Ub2der(iii,j)
6166         dipj(iii,2)=b1(iii,itj1)
6167       enddo
6168       kkk=0
6169       do iii=1,2
6170         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6171         do jjj=1,2
6172           kkk=kkk+1
6173           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6174         enddo
6175       enddo
6176       if (.not.calc_grad) return
6177       do kkk=1,5
6178         do lll=1,3
6179           mmm=0
6180           do iii=1,2
6181             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6182      &        auxvec(1))
6183             do jjj=1,2
6184               mmm=mmm+1
6185               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6186             enddo
6187           enddo
6188         enddo
6189       enddo
6190       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6191       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6192       do iii=1,2
6193         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6194       enddo
6195       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6196       do iii=1,2
6197         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6198       enddo
6199       return
6200       end
6201 C---------------------------------------------------------------------------
6202       subroutine calc_eello(i,j,k,l,jj,kk)
6203 C
6204 C This subroutine computes matrices and vectors needed to calculate
6205 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6206 C
6207       implicit real*8 (a-h,o-z)
6208       include 'DIMENSIONS'
6209       include 'sizesclu.dat'
6210       include 'COMMON.IOUNITS'
6211       include 'COMMON.CHAIN'
6212       include 'COMMON.DERIV'
6213       include 'COMMON.INTERACT'
6214       include 'COMMON.CONTACTS'
6215       include 'COMMON.TORSION'
6216       include 'COMMON.VAR'
6217       include 'COMMON.GEO'
6218       include 'COMMON.FFIELD'
6219       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6220      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6221       logical lprn
6222       common /kutas/ lprn
6223 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6224 cd     & ' jj=',jj,' kk=',kk
6225 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6226       do iii=1,2
6227         do jjj=1,2
6228           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6229           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6230         enddo
6231       enddo
6232       call transpose2(aa1(1,1),aa1t(1,1))
6233       call transpose2(aa2(1,1),aa2t(1,1))
6234       do kkk=1,5
6235         do lll=1,3
6236           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6237      &      aa1tder(1,1,lll,kkk))
6238           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6239      &      aa2tder(1,1,lll,kkk))
6240         enddo
6241       enddo
6242       if (l.eq.j+1) then
6243 C parallel orientation of the two CA-CA-CA frames.
6244 c        if (i.gt.1) then
6245         if (i.gt.1 .and. itype(i).le.ntyp) then
6246           iti=itortyp(itype(i))
6247         else
6248           iti=ntortyp+1
6249         endif
6250         itk1=itortyp(itype(k+1))
6251         itj=itortyp(itype(j))
6252 c        if (l.lt.nres-1) then
6253         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6254           itl1=itortyp(itype(l+1))
6255         else
6256           itl1=ntortyp+1
6257         endif
6258 C A1 kernel(j+1) A2T
6259 cd        do iii=1,2
6260 cd          write (iout,'(3f10.5,5x,3f10.5)')
6261 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6262 cd        enddo
6263         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6264      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6265      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6266 C Following matrices are needed only for 6-th order cumulants
6267         IF (wcorr6.gt.0.0d0) THEN
6268         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6269      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6270      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6271         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6272      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6273      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6274      &   ADtEAderx(1,1,1,1,1,1))
6275         lprn=.false.
6276         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6277      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6278      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6279      &   ADtEA1derx(1,1,1,1,1,1))
6280         ENDIF
6281 C End 6-th order cumulants
6282 cd        lprn=.false.
6283 cd        if (lprn) then
6284 cd        write (2,*) 'In calc_eello6'
6285 cd        do iii=1,2
6286 cd          write (2,*) 'iii=',iii
6287 cd          do kkk=1,5
6288 cd            write (2,*) 'kkk=',kkk
6289 cd            do jjj=1,2
6290 cd              write (2,'(3(2f10.5),5x)')
6291 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6292 cd            enddo
6293 cd          enddo
6294 cd        enddo
6295 cd        endif
6296         call transpose2(EUgder(1,1,k),auxmat(1,1))
6297         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6298         call transpose2(EUg(1,1,k),auxmat(1,1))
6299         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6300         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6301         do iii=1,2
6302           do kkk=1,5
6303             do lll=1,3
6304               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6305      &          EAEAderx(1,1,lll,kkk,iii,1))
6306             enddo
6307           enddo
6308         enddo
6309 C A1T kernel(i+1) A2
6310         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6311      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6312      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6313 C Following matrices are needed only for 6-th order cumulants
6314         IF (wcorr6.gt.0.0d0) THEN
6315         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6316      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6317      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6318         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6319      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6320      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6321      &   ADtEAderx(1,1,1,1,1,2))
6322         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6323      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6324      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6325      &   ADtEA1derx(1,1,1,1,1,2))
6326         ENDIF
6327 C End 6-th order cumulants
6328         call transpose2(EUgder(1,1,l),auxmat(1,1))
6329         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6330         call transpose2(EUg(1,1,l),auxmat(1,1))
6331         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6332         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6333         do iii=1,2
6334           do kkk=1,5
6335             do lll=1,3
6336               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6337      &          EAEAderx(1,1,lll,kkk,iii,2))
6338             enddo
6339           enddo
6340         enddo
6341 C AEAb1 and AEAb2
6342 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6343 C They are needed only when the fifth- or the sixth-order cumulants are
6344 C indluded.
6345         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6346         call transpose2(AEA(1,1,1),auxmat(1,1))
6347         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6348         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6349         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6350         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6351         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6352         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6353         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6354         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6355         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6356         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6357         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6358         call transpose2(AEA(1,1,2),auxmat(1,1))
6359         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6360         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6361         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6362         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6363         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6364         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6365         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6366         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6367         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6368         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6369         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6370 C Calculate the Cartesian derivatives of the vectors.
6371         do iii=1,2
6372           do kkk=1,5
6373             do lll=1,3
6374               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6375               call matvec2(auxmat(1,1),b1(1,iti),
6376      &          AEAb1derx(1,lll,kkk,iii,1,1))
6377               call matvec2(auxmat(1,1),Ub2(1,i),
6378      &          AEAb2derx(1,lll,kkk,iii,1,1))
6379               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6380      &          AEAb1derx(1,lll,kkk,iii,2,1))
6381               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6382      &          AEAb2derx(1,lll,kkk,iii,2,1))
6383               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6384               call matvec2(auxmat(1,1),b1(1,itj),
6385      &          AEAb1derx(1,lll,kkk,iii,1,2))
6386               call matvec2(auxmat(1,1),Ub2(1,j),
6387      &          AEAb2derx(1,lll,kkk,iii,1,2))
6388               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6389      &          AEAb1derx(1,lll,kkk,iii,2,2))
6390               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6391      &          AEAb2derx(1,lll,kkk,iii,2,2))
6392             enddo
6393           enddo
6394         enddo
6395         ENDIF
6396 C End vectors
6397       else
6398 C Antiparallel orientation of the two CA-CA-CA frames.
6399 c        if (i.gt.1) then
6400         if (i.gt.1 .and. itype(i).le.ntyp) then
6401           iti=itortyp(itype(i))
6402         else
6403           iti=ntortyp+1
6404         endif
6405         itk1=itortyp(itype(k+1))
6406         itl=itortyp(itype(l))
6407         itj=itortyp(itype(j))
6408 c        if (j.lt.nres-1) then
6409         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6410           itj1=itortyp(itype(j+1))
6411         else
6412           itj1=ntortyp+1
6413         endif
6414 C A2 kernel(j-1)T A1T
6415         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6416      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6417      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6418 C Following matrices are needed only for 6-th order cumulants
6419         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6420      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6421         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6422      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6423      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6424         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6425      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6426      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6427      &   ADtEAderx(1,1,1,1,1,1))
6428         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6429      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6430      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6431      &   ADtEA1derx(1,1,1,1,1,1))
6432         ENDIF
6433 C End 6-th order cumulants
6434         call transpose2(EUgder(1,1,k),auxmat(1,1))
6435         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6436         call transpose2(EUg(1,1,k),auxmat(1,1))
6437         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6438         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6439         do iii=1,2
6440           do kkk=1,5
6441             do lll=1,3
6442               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6443      &          EAEAderx(1,1,lll,kkk,iii,1))
6444             enddo
6445           enddo
6446         enddo
6447 C A2T kernel(i+1)T A1
6448         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6449      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6450      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6451 C Following matrices are needed only for 6-th order cumulants
6452         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6453      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6454         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6455      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6456      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6457         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6458      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6459      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6460      &   ADtEAderx(1,1,1,1,1,2))
6461         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6462      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6463      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6464      &   ADtEA1derx(1,1,1,1,1,2))
6465         ENDIF
6466 C End 6-th order cumulants
6467         call transpose2(EUgder(1,1,j),auxmat(1,1))
6468         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6469         call transpose2(EUg(1,1,j),auxmat(1,1))
6470         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6471         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6472         do iii=1,2
6473           do kkk=1,5
6474             do lll=1,3
6475               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6476      &          EAEAderx(1,1,lll,kkk,iii,2))
6477             enddo
6478           enddo
6479         enddo
6480 C AEAb1 and AEAb2
6481 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6482 C They are needed only when the fifth- or the sixth-order cumulants are
6483 C indluded.
6484         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6485      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6486         call transpose2(AEA(1,1,1),auxmat(1,1))
6487         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6488         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6489         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6490         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6491         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6492         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6493         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6494         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6495         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6496         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6497         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6498         call transpose2(AEA(1,1,2),auxmat(1,1))
6499         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6500         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6501         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6502         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6503         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6504         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6505         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6506         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6507         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6508         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6509         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6510 C Calculate the Cartesian derivatives of the vectors.
6511         do iii=1,2
6512           do kkk=1,5
6513             do lll=1,3
6514               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6515               call matvec2(auxmat(1,1),b1(1,iti),
6516      &          AEAb1derx(1,lll,kkk,iii,1,1))
6517               call matvec2(auxmat(1,1),Ub2(1,i),
6518      &          AEAb2derx(1,lll,kkk,iii,1,1))
6519               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6520      &          AEAb1derx(1,lll,kkk,iii,2,1))
6521               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6522      &          AEAb2derx(1,lll,kkk,iii,2,1))
6523               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6524               call matvec2(auxmat(1,1),b1(1,itl),
6525      &          AEAb1derx(1,lll,kkk,iii,1,2))
6526               call matvec2(auxmat(1,1),Ub2(1,l),
6527      &          AEAb2derx(1,lll,kkk,iii,1,2))
6528               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6529      &          AEAb1derx(1,lll,kkk,iii,2,2))
6530               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6531      &          AEAb2derx(1,lll,kkk,iii,2,2))
6532             enddo
6533           enddo
6534         enddo
6535         ENDIF
6536 C End vectors
6537       endif
6538       return
6539       end
6540 C---------------------------------------------------------------------------
6541       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6542      &  KK,KKderg,AKA,AKAderg,AKAderx)
6543       implicit none
6544       integer nderg
6545       logical transp
6546       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6547      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6548      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6549       integer iii,kkk,lll
6550       integer jjj,mmm
6551       logical lprn
6552       common /kutas/ lprn
6553       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6554       do iii=1,nderg
6555         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6556      &    AKAderg(1,1,iii))
6557       enddo
6558 cd      if (lprn) write (2,*) 'In kernel'
6559       do kkk=1,5
6560 cd        if (lprn) write (2,*) 'kkk=',kkk
6561         do lll=1,3
6562           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6563      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6564 cd          if (lprn) then
6565 cd            write (2,*) 'lll=',lll
6566 cd            write (2,*) 'iii=1'
6567 cd            do jjj=1,2
6568 cd              write (2,'(3(2f10.5),5x)')
6569 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6570 cd            enddo
6571 cd          endif
6572           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6573      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6574 cd          if (lprn) then
6575 cd            write (2,*) 'lll=',lll
6576 cd            write (2,*) 'iii=2'
6577 cd            do jjj=1,2
6578 cd              write (2,'(3(2f10.5),5x)')
6579 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6580 cd            enddo
6581 cd          endif
6582         enddo
6583       enddo
6584       return
6585       end
6586 C---------------------------------------------------------------------------
6587       double precision function eello4(i,j,k,l,jj,kk)
6588       implicit real*8 (a-h,o-z)
6589       include 'DIMENSIONS'
6590       include 'sizesclu.dat'
6591       include 'COMMON.IOUNITS'
6592       include 'COMMON.CHAIN'
6593       include 'COMMON.DERIV'
6594       include 'COMMON.INTERACT'
6595       include 'COMMON.CONTACTS'
6596       include 'COMMON.TORSION'
6597       include 'COMMON.VAR'
6598       include 'COMMON.GEO'
6599       double precision pizda(2,2),ggg1(3),ggg2(3)
6600 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6601 cd        eello4=0.0d0
6602 cd        return
6603 cd      endif
6604 cd      print *,'eello4:',i,j,k,l,jj,kk
6605 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6606 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6607 cold      eij=facont_hb(jj,i)
6608 cold      ekl=facont_hb(kk,k)
6609 cold      ekont=eij*ekl
6610       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6611       if (calc_grad) then
6612 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6613       gcorr_loc(k-1)=gcorr_loc(k-1)
6614      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6615       if (l.eq.j+1) then
6616         gcorr_loc(l-1)=gcorr_loc(l-1)
6617      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6618       else
6619         gcorr_loc(j-1)=gcorr_loc(j-1)
6620      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6621       endif
6622       do iii=1,2
6623         do kkk=1,5
6624           do lll=1,3
6625             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6626      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6627 cd            derx(lll,kkk,iii)=0.0d0
6628           enddo
6629         enddo
6630       enddo
6631 cd      gcorr_loc(l-1)=0.0d0
6632 cd      gcorr_loc(j-1)=0.0d0
6633 cd      gcorr_loc(k-1)=0.0d0
6634 cd      eel4=1.0d0
6635 cd      write (iout,*)'Contacts have occurred for peptide groups',
6636 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6637 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6638       if (j.lt.nres-1) then
6639         j1=j+1
6640         j2=j-1
6641       else
6642         j1=j-1
6643         j2=j-2
6644       endif
6645       if (l.lt.nres-1) then
6646         l1=l+1
6647         l2=l-1
6648       else
6649         l1=l-1
6650         l2=l-2
6651       endif
6652       do ll=1,3
6653 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6654         ggg1(ll)=eel4*g_contij(ll,1)
6655         ggg2(ll)=eel4*g_contij(ll,2)
6656         ghalf=0.5d0*ggg1(ll)
6657 cd        ghalf=0.0d0
6658         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6659         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6660         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6661         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6662 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6663         ghalf=0.5d0*ggg2(ll)
6664 cd        ghalf=0.0d0
6665         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6666         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6667         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6668         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6669       enddo
6670 cd      goto 1112
6671       do m=i+1,j-1
6672         do ll=1,3
6673 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6674           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6675         enddo
6676       enddo
6677       do m=k+1,l-1
6678         do ll=1,3
6679 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6680           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6681         enddo
6682       enddo
6683 1112  continue
6684       do m=i+2,j2
6685         do ll=1,3
6686           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6687         enddo
6688       enddo
6689       do m=k+2,l2
6690         do ll=1,3
6691           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6692         enddo
6693       enddo
6694 cd      do iii=1,nres-3
6695 cd        write (2,*) iii,gcorr_loc(iii)
6696 cd      enddo
6697       endif
6698       eello4=ekont*eel4
6699 cd      write (2,*) 'ekont',ekont
6700 cd      write (iout,*) 'eello4',ekont*eel4
6701       return
6702       end
6703 C---------------------------------------------------------------------------
6704       double precision function eello5(i,j,k,l,jj,kk)
6705       implicit real*8 (a-h,o-z)
6706       include 'DIMENSIONS'
6707       include 'sizesclu.dat'
6708       include 'COMMON.IOUNITS'
6709       include 'COMMON.CHAIN'
6710       include 'COMMON.DERIV'
6711       include 'COMMON.INTERACT'
6712       include 'COMMON.CONTACTS'
6713       include 'COMMON.TORSION'
6714       include 'COMMON.VAR'
6715       include 'COMMON.GEO'
6716       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6717       double precision ggg1(3),ggg2(3)
6718 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6719 C                                                                              C
6720 C                            Parallel chains                                   C
6721 C                                                                              C
6722 C          o             o                   o             o                   C
6723 C         /l\           / \             \   / \           / \   /              C
6724 C        /   \         /   \             \ /   \         /   \ /               C
6725 C       j| o |l1       | o |              o| o |         | o |o                C
6726 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6727 C      \i/   \         /   \ /             /   \         /   \                 C
6728 C       o    k1             o                                                  C
6729 C         (I)          (II)                (III)          (IV)                 C
6730 C                                                                              C
6731 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6732 C                                                                              C
6733 C                            Antiparallel chains                               C
6734 C                                                                              C
6735 C          o             o                   o             o                   C
6736 C         /j\           / \             \   / \           / \   /              C
6737 C        /   \         /   \             \ /   \         /   \ /               C
6738 C      j1| o |l        | o |              o| o |         | o |o                C
6739 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6740 C      \i/   \         /   \ /             /   \         /   \                 C
6741 C       o     k1            o                                                  C
6742 C         (I)          (II)                (III)          (IV)                 C
6743 C                                                                              C
6744 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6745 C                                                                              C
6746 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6747 C                                                                              C
6748 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6749 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6750 cd        eello5=0.0d0
6751 cd        return
6752 cd      endif
6753 cd      write (iout,*)
6754 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6755 cd     &   ' and',k,l
6756       itk=itortyp(itype(k))
6757       itl=itortyp(itype(l))
6758       itj=itortyp(itype(j))
6759       eello5_1=0.0d0
6760       eello5_2=0.0d0
6761       eello5_3=0.0d0
6762       eello5_4=0.0d0
6763 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6764 cd     &   eel5_3_num,eel5_4_num)
6765       do iii=1,2
6766         do kkk=1,5
6767           do lll=1,3
6768             derx(lll,kkk,iii)=0.0d0
6769           enddo
6770         enddo
6771       enddo
6772 cd      eij=facont_hb(jj,i)
6773 cd      ekl=facont_hb(kk,k)
6774 cd      ekont=eij*ekl
6775 cd      write (iout,*)'Contacts have occurred for peptide groups',
6776 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6777 cd      goto 1111
6778 C Contribution from the graph I.
6779 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6780 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6781       call transpose2(EUg(1,1,k),auxmat(1,1))
6782       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6783       vv(1)=pizda(1,1)-pizda(2,2)
6784       vv(2)=pizda(1,2)+pizda(2,1)
6785       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6786      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6787       if (calc_grad) then
6788 C Explicit gradient in virtual-dihedral angles.
6789       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6790      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6791      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6792       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6793       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6794       vv(1)=pizda(1,1)-pizda(2,2)
6795       vv(2)=pizda(1,2)+pizda(2,1)
6796       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6797      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6798      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6799       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6800       vv(1)=pizda(1,1)-pizda(2,2)
6801       vv(2)=pizda(1,2)+pizda(2,1)
6802       if (l.eq.j+1) then
6803         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6804      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6805      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6806       else
6807         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6808      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6809      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6810       endif
6811 C Cartesian gradient
6812       do iii=1,2
6813         do kkk=1,5
6814           do lll=1,3
6815             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6816      &        pizda(1,1))
6817             vv(1)=pizda(1,1)-pizda(2,2)
6818             vv(2)=pizda(1,2)+pizda(2,1)
6819             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6820      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6821      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6822           enddo
6823         enddo
6824       enddo
6825 c      goto 1112
6826       endif
6827 c1111  continue
6828 C Contribution from graph II
6829       call transpose2(EE(1,1,itk),auxmat(1,1))
6830       call matmat2(auxmat(1,1),AEA(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       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6834      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6835       if (calc_grad) then
6836 C Explicit gradient in virtual-dihedral angles.
6837       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6838      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6839       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6840       vv(1)=pizda(1,1)+pizda(2,2)
6841       vv(2)=pizda(2,1)-pizda(1,2)
6842       if (l.eq.j+1) then
6843         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6844      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6845      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6846       else
6847         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6848      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6849      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6850       endif
6851 C Cartesian gradient
6852       do iii=1,2
6853         do kkk=1,5
6854           do lll=1,3
6855             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6856      &        pizda(1,1))
6857             vv(1)=pizda(1,1)+pizda(2,2)
6858             vv(2)=pizda(2,1)-pizda(1,2)
6859             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6860      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6861      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6862           enddo
6863         enddo
6864       enddo
6865 cd      goto 1112
6866       endif
6867 cd1111  continue
6868       if (l.eq.j+1) then
6869 cd        goto 1110
6870 C Parallel orientation
6871 C Contribution from graph III
6872         call transpose2(EUg(1,1,l),auxmat(1,1))
6873         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6874         vv(1)=pizda(1,1)-pizda(2,2)
6875         vv(2)=pizda(1,2)+pizda(2,1)
6876         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6877      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6878         if (calc_grad) then
6879 C Explicit gradient in virtual-dihedral angles.
6880         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6881      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6882      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6883         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6884         vv(1)=pizda(1,1)-pizda(2,2)
6885         vv(2)=pizda(1,2)+pizda(2,1)
6886         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6887      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6888      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6889         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6890         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6891         vv(1)=pizda(1,1)-pizda(2,2)
6892         vv(2)=pizda(1,2)+pizda(2,1)
6893         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6894      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6895      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6896 C Cartesian gradient
6897         do iii=1,2
6898           do kkk=1,5
6899             do lll=1,3
6900               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6901      &          pizda(1,1))
6902               vv(1)=pizda(1,1)-pizda(2,2)
6903               vv(2)=pizda(1,2)+pizda(2,1)
6904               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6905      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6906      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6907             enddo
6908           enddo
6909         enddo
6910 cd        goto 1112
6911         endif
6912 C Contribution from graph IV
6913 cd1110    continue
6914         call transpose2(EE(1,1,itl),auxmat(1,1))
6915         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6919      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6920         if (calc_grad) then
6921 C Explicit gradient in virtual-dihedral angles.
6922         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6923      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6924         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6925         vv(1)=pizda(1,1)+pizda(2,2)
6926         vv(2)=pizda(2,1)-pizda(1,2)
6927         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6928      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6929      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6930 C Cartesian gradient
6931         do iii=1,2
6932           do kkk=1,5
6933             do lll=1,3
6934               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6935      &          pizda(1,1))
6936               vv(1)=pizda(1,1)+pizda(2,2)
6937               vv(2)=pizda(2,1)-pizda(1,2)
6938               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6939      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6940      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6941             enddo
6942           enddo
6943         enddo
6944         endif
6945       else
6946 C Antiparallel orientation
6947 C Contribution from graph III
6948 c        goto 1110
6949         call transpose2(EUg(1,1,j),auxmat(1,1))
6950         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6951         vv(1)=pizda(1,1)-pizda(2,2)
6952         vv(2)=pizda(1,2)+pizda(2,1)
6953         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6954      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6955         if (calc_grad) then
6956 C Explicit gradient in virtual-dihedral angles.
6957         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6958      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6959      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6960         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6961         vv(1)=pizda(1,1)-pizda(2,2)
6962         vv(2)=pizda(1,2)+pizda(2,1)
6963         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6964      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6965      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6966         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6967         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6968         vv(1)=pizda(1,1)-pizda(2,2)
6969         vv(2)=pizda(1,2)+pizda(2,1)
6970         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6971      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6972      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6973 C Cartesian gradient
6974         do iii=1,2
6975           do kkk=1,5
6976             do lll=1,3
6977               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6978      &          pizda(1,1))
6979               vv(1)=pizda(1,1)-pizda(2,2)
6980               vv(2)=pizda(1,2)+pizda(2,1)
6981               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6982      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6983      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6984             enddo
6985           enddo
6986         enddo
6987 cd        goto 1112
6988         endif
6989 C Contribution from graph IV
6990 1110    continue
6991         call transpose2(EE(1,1,itj),auxmat(1,1))
6992         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6996      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6997         if (calc_grad) then
6998 C Explicit gradient in virtual-dihedral angles.
6999         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7000      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7001         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7002         vv(1)=pizda(1,1)+pizda(2,2)
7003         vv(2)=pizda(2,1)-pizda(1,2)
7004         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7005      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7006      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7007 C Cartesian gradient
7008         do iii=1,2
7009           do kkk=1,5
7010             do lll=1,3
7011               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7012      &          pizda(1,1))
7013               vv(1)=pizda(1,1)+pizda(2,2)
7014               vv(2)=pizda(2,1)-pizda(1,2)
7015               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7016      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7017      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7018             enddo
7019           enddo
7020         enddo
7021       endif
7022       endif
7023 1112  continue
7024       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7025 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7026 cd        write (2,*) 'ijkl',i,j,k,l
7027 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7028 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7029 cd      endif
7030 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7031 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7032 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7033 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7034       if (calc_grad) then
7035       if (j.lt.nres-1) then
7036         j1=j+1
7037         j2=j-1
7038       else
7039         j1=j-1
7040         j2=j-2
7041       endif
7042       if (l.lt.nres-1) then
7043         l1=l+1
7044         l2=l-1
7045       else
7046         l1=l-1
7047         l2=l-2
7048       endif
7049 cd      eij=1.0d0
7050 cd      ekl=1.0d0
7051 cd      ekont=1.0d0
7052 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7053       do ll=1,3
7054         ggg1(ll)=eel5*g_contij(ll,1)
7055         ggg2(ll)=eel5*g_contij(ll,2)
7056 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7057         ghalf=0.5d0*ggg1(ll)
7058 cd        ghalf=0.0d0
7059         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7060         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7061         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7062         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7063 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7064         ghalf=0.5d0*ggg2(ll)
7065 cd        ghalf=0.0d0
7066         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7067         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7068         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7069         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7070       enddo
7071 cd      goto 1112
7072       do m=i+1,j-1
7073         do ll=1,3
7074 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7075           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7076         enddo
7077       enddo
7078       do m=k+1,l-1
7079         do ll=1,3
7080 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7081           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7082         enddo
7083       enddo
7084 c1112  continue
7085       do m=i+2,j2
7086         do ll=1,3
7087           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7088         enddo
7089       enddo
7090       do m=k+2,l2
7091         do ll=1,3
7092           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7093         enddo
7094       enddo
7095 cd      do iii=1,nres-3
7096 cd        write (2,*) iii,g_corr5_loc(iii)
7097 cd      enddo
7098       endif
7099       eello5=ekont*eel5
7100 cd      write (2,*) 'ekont',ekont
7101 cd      write (iout,*) 'eello5',ekont*eel5
7102       return
7103       end
7104 c--------------------------------------------------------------------------
7105       double precision function eello6(i,j,k,l,jj,kk)
7106       implicit real*8 (a-h,o-z)
7107       include 'DIMENSIONS'
7108       include 'sizesclu.dat'
7109       include 'COMMON.IOUNITS'
7110       include 'COMMON.CHAIN'
7111       include 'COMMON.DERIV'
7112       include 'COMMON.INTERACT'
7113       include 'COMMON.CONTACTS'
7114       include 'COMMON.TORSION'
7115       include 'COMMON.VAR'
7116       include 'COMMON.GEO'
7117       include 'COMMON.FFIELD'
7118       double precision ggg1(3),ggg2(3)
7119 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7120 cd        eello6=0.0d0
7121 cd        return
7122 cd      endif
7123 cd      write (iout,*)
7124 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7125 cd     &   ' and',k,l
7126       eello6_1=0.0d0
7127       eello6_2=0.0d0
7128       eello6_3=0.0d0
7129       eello6_4=0.0d0
7130       eello6_5=0.0d0
7131       eello6_6=0.0d0
7132 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7133 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7134       do iii=1,2
7135         do kkk=1,5
7136           do lll=1,3
7137             derx(lll,kkk,iii)=0.0d0
7138           enddo
7139         enddo
7140       enddo
7141 cd      eij=facont_hb(jj,i)
7142 cd      ekl=facont_hb(kk,k)
7143 cd      ekont=eij*ekl
7144 cd      eij=1.0d0
7145 cd      ekl=1.0d0
7146 cd      ekont=1.0d0
7147       if (l.eq.j+1) then
7148         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7149         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7150         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7151         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7152         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7153         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7154       else
7155         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7156         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7157         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7158         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7159         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7160           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7161         else
7162           eello6_5=0.0d0
7163         endif
7164         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7165       endif
7166 C If turn contributions are considered, they will be handled separately.
7167       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7168 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7169 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7170 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7171 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7172 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7173 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7174 cd      goto 1112
7175       if (calc_grad) then
7176       if (j.lt.nres-1) then
7177         j1=j+1
7178         j2=j-1
7179       else
7180         j1=j-1
7181         j2=j-2
7182       endif
7183       if (l.lt.nres-1) then
7184         l1=l+1
7185         l2=l-1
7186       else
7187         l1=l-1
7188         l2=l-2
7189       endif
7190       do ll=1,3
7191         ggg1(ll)=eel6*g_contij(ll,1)
7192         ggg2(ll)=eel6*g_contij(ll,2)
7193 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7194         ghalf=0.5d0*ggg1(ll)
7195 cd        ghalf=0.0d0
7196         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7197         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7198         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7199         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7200         ghalf=0.5d0*ggg2(ll)
7201 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7202 cd        ghalf=0.0d0
7203         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7204         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7205         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7206         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7207       enddo
7208 cd      goto 1112
7209       do m=i+1,j-1
7210         do ll=1,3
7211 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7212           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7213         enddo
7214       enddo
7215       do m=k+1,l-1
7216         do ll=1,3
7217 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7218           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7219         enddo
7220       enddo
7221 1112  continue
7222       do m=i+2,j2
7223         do ll=1,3
7224           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7225         enddo
7226       enddo
7227       do m=k+2,l2
7228         do ll=1,3
7229           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7230         enddo
7231       enddo
7232 cd      do iii=1,nres-3
7233 cd        write (2,*) iii,g_corr6_loc(iii)
7234 cd      enddo
7235       endif
7236       eello6=ekont*eel6
7237 cd      write (2,*) 'ekont',ekont
7238 cd      write (iout,*) 'eello6',ekont*eel6
7239       return
7240       end
7241 c--------------------------------------------------------------------------
7242       double precision function eello6_graph1(i,j,k,l,imat,swap)
7243       implicit real*8 (a-h,o-z)
7244       include 'DIMENSIONS'
7245       include 'sizesclu.dat'
7246       include 'COMMON.IOUNITS'
7247       include 'COMMON.CHAIN'
7248       include 'COMMON.DERIV'
7249       include 'COMMON.INTERACT'
7250       include 'COMMON.CONTACTS'
7251       include 'COMMON.TORSION'
7252       include 'COMMON.VAR'
7253       include 'COMMON.GEO'
7254       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7255       logical swap
7256       logical lprn
7257       common /kutas/ lprn
7258 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7259 C                                                                              C
7260 C      Parallel       Antiparallel                                             C
7261 C                                                                              C
7262 C          o             o                                                     C
7263 C         /l\           /j\                                                    C
7264 C        /   \         /   \                                                   C
7265 C       /| o |         | o |\                                                  C
7266 C     \ j|/k\|  /   \  |/k\|l /                                                C
7267 C      \ /   \ /     \ /   \ /                                                 C
7268 C       o     o       o     o                                                  C
7269 C       i             i                                                        C
7270 C                                                                              C
7271 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7272       itk=itortyp(itype(k))
7273       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7274       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7275       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7276       call transpose2(EUgC(1,1,k),auxmat(1,1))
7277       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7278       vv1(1)=pizda1(1,1)-pizda1(2,2)
7279       vv1(2)=pizda1(1,2)+pizda1(2,1)
7280       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7281       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7282       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7283       s5=scalar2(vv(1),Dtobr2(1,i))
7284 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7285       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7286       if (.not. calc_grad) return
7287       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7288      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7289      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7290      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7291      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7292      & +scalar2(vv(1),Dtobr2der(1,i)))
7293       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7294       vv1(1)=pizda1(1,1)-pizda1(2,2)
7295       vv1(2)=pizda1(1,2)+pizda1(2,1)
7296       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7297       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7298       if (l.eq.j+1) then
7299         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7300      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7301      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7302      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7303      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7304       else
7305         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7306      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7307      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7308      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7309      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7310       endif
7311       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7312       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7313       vv1(1)=pizda1(1,1)-pizda1(2,2)
7314       vv1(2)=pizda1(1,2)+pizda1(2,1)
7315       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7316      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7317      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7318      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7319       do iii=1,2
7320         if (swap) then
7321           ind=3-iii
7322         else
7323           ind=iii
7324         endif
7325         do kkk=1,5
7326           do lll=1,3
7327             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7328             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7329             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7330             call transpose2(EUgC(1,1,k),auxmat(1,1))
7331             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7332      &        pizda1(1,1))
7333             vv1(1)=pizda1(1,1)-pizda1(2,2)
7334             vv1(2)=pizda1(1,2)+pizda1(2,1)
7335             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7336             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7337      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7338             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7339      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7340             s5=scalar2(vv(1),Dtobr2(1,i))
7341             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7342           enddo
7343         enddo
7344       enddo
7345       return
7346       end
7347 c----------------------------------------------------------------------------
7348       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7349       implicit real*8 (a-h,o-z)
7350       include 'DIMENSIONS'
7351       include 'sizesclu.dat'
7352       include 'COMMON.IOUNITS'
7353       include 'COMMON.CHAIN'
7354       include 'COMMON.DERIV'
7355       include 'COMMON.INTERACT'
7356       include 'COMMON.CONTACTS'
7357       include 'COMMON.TORSION'
7358       include 'COMMON.VAR'
7359       include 'COMMON.GEO'
7360       logical swap
7361       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7362      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7363       logical lprn
7364       common /kutas/ lprn
7365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7366 C                                                                              C
7367 C      Parallel       Antiparallel                                             C
7368 C                                                                              C
7369 C          o             o                                                     C
7370 C     \   /l\           /j\   /                                                C
7371 C      \ /   \         /   \ /                                                 C
7372 C       o| o |         | o |o                                                  C
7373 C     \ j|/k\|      \  |/k\|l                                                  C
7374 C      \ /   \       \ /   \                                                   C
7375 C       o             o                                                        C
7376 C       i             i                                                        C
7377 C                                                                              C
7378 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7379 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7380 C AL 7/4/01 s1 would occur in the sixth-order moment,
7381 C           but not in a cluster cumulant
7382 #ifdef MOMENT
7383       s1=dip(1,jj,i)*dip(1,kk,k)
7384 #endif
7385       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7386       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7387       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7388       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7389       call transpose2(EUg(1,1,k),auxmat(1,1))
7390       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7391       vv(1)=pizda(1,1)-pizda(2,2)
7392       vv(2)=pizda(1,2)+pizda(2,1)
7393       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7394 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7395 #ifdef MOMENT
7396       eello6_graph2=-(s1+s2+s3+s4)
7397 #else
7398       eello6_graph2=-(s2+s3+s4)
7399 #endif
7400 c      eello6_graph2=-s3
7401       if (.not. calc_grad) return
7402 C Derivatives in gamma(i-1)
7403       if (i.gt.1) then
7404 #ifdef MOMENT
7405         s1=dipderg(1,jj,i)*dip(1,kk,k)
7406 #endif
7407         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7408         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7409         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7410         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7411 #ifdef MOMENT
7412         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7413 #else
7414         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7415 #endif
7416 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7417       endif
7418 C Derivatives in gamma(k-1)
7419 #ifdef MOMENT
7420       s1=dip(1,jj,i)*dipderg(1,kk,k)
7421 #endif
7422       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7423       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7424       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7425       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7426       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7427       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7428       vv(1)=pizda(1,1)-pizda(2,2)
7429       vv(2)=pizda(1,2)+pizda(2,1)
7430       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7431 #ifdef MOMENT
7432       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7433 #else
7434       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7435 #endif
7436 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7437 C Derivatives in gamma(j-1) or gamma(l-1)
7438       if (j.gt.1) then
7439 #ifdef MOMENT
7440         s1=dipderg(3,jj,i)*dip(1,kk,k)
7441 #endif
7442         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7443         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7444         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7445         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7446         vv(1)=pizda(1,1)-pizda(2,2)
7447         vv(2)=pizda(1,2)+pizda(2,1)
7448         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7449 #ifdef MOMENT
7450         if (swap) then
7451           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7452         else
7453           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7454         endif
7455 #endif
7456         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7457 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7458       endif
7459 C Derivatives in gamma(l-1) or gamma(j-1)
7460       if (l.gt.1) then
7461 #ifdef MOMENT
7462         s1=dip(1,jj,i)*dipderg(3,kk,k)
7463 #endif
7464         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7465         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7466         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7467         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7468         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7469         vv(1)=pizda(1,1)-pizda(2,2)
7470         vv(2)=pizda(1,2)+pizda(2,1)
7471         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7472 #ifdef MOMENT
7473         if (swap) then
7474           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7475         else
7476           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7477         endif
7478 #endif
7479         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7480 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7481       endif
7482 C Cartesian derivatives.
7483       if (lprn) then
7484         write (2,*) 'In eello6_graph2'
7485         do iii=1,2
7486           write (2,*) 'iii=',iii
7487           do kkk=1,5
7488             write (2,*) 'kkk=',kkk
7489             do jjj=1,2
7490               write (2,'(3(2f10.5),5x)')
7491      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7492             enddo
7493           enddo
7494         enddo
7495       endif
7496       do iii=1,2
7497         do kkk=1,5
7498           do lll=1,3
7499 #ifdef MOMENT
7500             if (iii.eq.1) then
7501               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7502             else
7503               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7504             endif
7505 #endif
7506             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7507      &        auxvec(1))
7508             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7509             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7510      &        auxvec(1))
7511             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7512             call transpose2(EUg(1,1,k),auxmat(1,1))
7513             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7514      &        pizda(1,1))
7515             vv(1)=pizda(1,1)-pizda(2,2)
7516             vv(2)=pizda(1,2)+pizda(2,1)
7517             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7518 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7519 #ifdef MOMENT
7520             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7521 #else
7522             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7523 #endif
7524             if (swap) then
7525               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7526             else
7527               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7528             endif
7529           enddo
7530         enddo
7531       enddo
7532       return
7533       end
7534 c----------------------------------------------------------------------------
7535       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7536       implicit real*8 (a-h,o-z)
7537       include 'DIMENSIONS'
7538       include 'sizesclu.dat'
7539       include 'COMMON.IOUNITS'
7540       include 'COMMON.CHAIN'
7541       include 'COMMON.DERIV'
7542       include 'COMMON.INTERACT'
7543       include 'COMMON.CONTACTS'
7544       include 'COMMON.TORSION'
7545       include 'COMMON.VAR'
7546       include 'COMMON.GEO'
7547       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7548       logical swap
7549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7550 C                                                                              C
7551 C      Parallel       Antiparallel                                             C
7552 C                                                                              C
7553 C          o             o                                                     C
7554 C         /l\   /   \   /j\                                                    C
7555 C        /   \ /     \ /   \                                                   C
7556 C       /| o |o       o| o |\                                                  C
7557 C       j|/k\|  /      |/k\|l /                                                C
7558 C        /   \ /       /   \ /                                                 C
7559 C       /     o       /     o                                                  C
7560 C       i             i                                                        C
7561 C                                                                              C
7562 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7563 C
7564 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7565 C           energy moment and not to the cluster cumulant.
7566       iti=itortyp(itype(i))
7567 c      if (j.lt.nres-1) then
7568       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7569         itj1=itortyp(itype(j+1))
7570       else
7571         itj1=ntortyp+1
7572       endif
7573       itk=itortyp(itype(k))
7574       itk1=itortyp(itype(k+1))
7575 c      if (l.lt.nres-1) then
7576       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7577         itl1=itortyp(itype(l+1))
7578       else
7579         itl1=ntortyp+1
7580       endif
7581 #ifdef MOMENT
7582       s1=dip(4,jj,i)*dip(4,kk,k)
7583 #endif
7584       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7585       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7586       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7587       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7588       call transpose2(EE(1,1,itk),auxmat(1,1))
7589       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7590       vv(1)=pizda(1,1)+pizda(2,2)
7591       vv(2)=pizda(2,1)-pizda(1,2)
7592       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7593 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7594 #ifdef MOMENT
7595       eello6_graph3=-(s1+s2+s3+s4)
7596 #else
7597       eello6_graph3=-(s2+s3+s4)
7598 #endif
7599 c      eello6_graph3=-s4
7600       if (.not. calc_grad) return
7601 C Derivatives in gamma(k-1)
7602       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7603       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7604       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7605       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7606 C Derivatives in gamma(l-1)
7607       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7608       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7609       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7610       vv(1)=pizda(1,1)+pizda(2,2)
7611       vv(2)=pizda(2,1)-pizda(1,2)
7612       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7613       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7614 C Cartesian derivatives.
7615       do iii=1,2
7616         do kkk=1,5
7617           do lll=1,3
7618 #ifdef MOMENT
7619             if (iii.eq.1) then
7620               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7621             else
7622               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7623             endif
7624 #endif
7625             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7626      &        auxvec(1))
7627             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7628             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7629      &        auxvec(1))
7630             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7631             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7632      &        pizda(1,1))
7633             vv(1)=pizda(1,1)+pizda(2,2)
7634             vv(2)=pizda(2,1)-pizda(1,2)
7635             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7636 #ifdef MOMENT
7637             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7638 #else
7639             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7640 #endif
7641             if (swap) then
7642               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7643             else
7644               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7645             endif
7646 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7647           enddo
7648         enddo
7649       enddo
7650       return
7651       end
7652 c----------------------------------------------------------------------------
7653       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7654       implicit real*8 (a-h,o-z)
7655       include 'DIMENSIONS'
7656       include 'sizesclu.dat'
7657       include 'COMMON.IOUNITS'
7658       include 'COMMON.CHAIN'
7659       include 'COMMON.DERIV'
7660       include 'COMMON.INTERACT'
7661       include 'COMMON.CONTACTS'
7662       include 'COMMON.TORSION'
7663       include 'COMMON.VAR'
7664       include 'COMMON.GEO'
7665       include 'COMMON.FFIELD'
7666       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7667      & auxvec1(2),auxmat1(2,2)
7668       logical swap
7669 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7670 C                                                                              C
7671 C      Parallel       Antiparallel                                             C
7672 C                                                                              C
7673 C          o             o                                                     C
7674 C         /l\   /   \   /j\                                                    C
7675 C        /   \ /     \ /   \                                                   C
7676 C       /| o |o       o| o |\                                                  C
7677 C     \ j|/k\|      \  |/k\|l                                                  C
7678 C      \ /   \       \ /   \                                                   C
7679 C       o     \       o     \                                                  C
7680 C       i             i                                                        C
7681 C                                                                              C
7682 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7683 C
7684 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7685 C           energy moment and not to the cluster cumulant.
7686 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7687       iti=itortyp(itype(i))
7688       itj=itortyp(itype(j))
7689 c      if (j.lt.nres-1) then
7690       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7691         itj1=itortyp(itype(j+1))
7692       else
7693         itj1=ntortyp+1
7694       endif
7695       itk=itortyp(itype(k))
7696 c      if (k.lt.nres-1) then
7697       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7698         itk1=itortyp(itype(k+1))
7699       else
7700         itk1=ntortyp+1
7701       endif
7702       itl=itortyp(itype(l))
7703       if (l.lt.nres-1) then
7704         itl1=itortyp(itype(l+1))
7705       else
7706         itl1=ntortyp+1
7707       endif
7708 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7709 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7710 cd     & ' itl',itl,' itl1',itl1
7711 #ifdef MOMENT
7712       if (imat.eq.1) then
7713         s1=dip(3,jj,i)*dip(3,kk,k)
7714       else
7715         s1=dip(2,jj,j)*dip(2,kk,l)
7716       endif
7717 #endif
7718       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7719       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7720       if (j.eq.l+1) then
7721         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7722         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7723       else
7724         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7725         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7726       endif
7727       call transpose2(EUg(1,1,k),auxmat(1,1))
7728       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7729       vv(1)=pizda(1,1)-pizda(2,2)
7730       vv(2)=pizda(2,1)+pizda(1,2)
7731       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7732 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7733 #ifdef MOMENT
7734       eello6_graph4=-(s1+s2+s3+s4)
7735 #else
7736       eello6_graph4=-(s2+s3+s4)
7737 #endif
7738       if (.not. calc_grad) return
7739 C Derivatives in gamma(i-1)
7740       if (i.gt.1) then
7741 #ifdef MOMENT
7742         if (imat.eq.1) then
7743           s1=dipderg(2,jj,i)*dip(3,kk,k)
7744         else
7745           s1=dipderg(4,jj,j)*dip(2,kk,l)
7746         endif
7747 #endif
7748         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7749         if (j.eq.l+1) then
7750           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7751           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7752         else
7753           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7754           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7755         endif
7756         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7757         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7758 cd          write (2,*) 'turn6 derivatives'
7759 #ifdef MOMENT
7760           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7761 #else
7762           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7763 #endif
7764         else
7765 #ifdef MOMENT
7766           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7767 #else
7768           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7769 #endif
7770         endif
7771       endif
7772 C Derivatives in gamma(k-1)
7773 #ifdef MOMENT
7774       if (imat.eq.1) then
7775         s1=dip(3,jj,i)*dipderg(2,kk,k)
7776       else
7777         s1=dip(2,jj,j)*dipderg(4,kk,l)
7778       endif
7779 #endif
7780       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7781       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7782       if (j.eq.l+1) then
7783         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7784         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7785       else
7786         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7787         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7788       endif
7789       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7790       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7791       vv(1)=pizda(1,1)-pizda(2,2)
7792       vv(2)=pizda(2,1)+pizda(1,2)
7793       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7794       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7795 #ifdef MOMENT
7796         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7797 #else
7798         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7799 #endif
7800       else
7801 #ifdef MOMENT
7802         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7803 #else
7804         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7805 #endif
7806       endif
7807 C Derivatives in gamma(j-1) or gamma(l-1)
7808       if (l.eq.j+1 .and. l.gt.1) then
7809         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7810         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7811         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7812         vv(1)=pizda(1,1)-pizda(2,2)
7813         vv(2)=pizda(2,1)+pizda(1,2)
7814         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7815         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7816       else if (j.gt.1) then
7817         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7818         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7819         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7820         vv(1)=pizda(1,1)-pizda(2,2)
7821         vv(2)=pizda(2,1)+pizda(1,2)
7822         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7823         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7824           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7825         else
7826           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7827         endif
7828       endif
7829 C Cartesian derivatives.
7830       do iii=1,2
7831         do kkk=1,5
7832           do lll=1,3
7833 #ifdef MOMENT
7834             if (iii.eq.1) then
7835               if (imat.eq.1) then
7836                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7837               else
7838                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7839               endif
7840             else
7841               if (imat.eq.1) then
7842                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7843               else
7844                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7845               endif
7846             endif
7847 #endif
7848             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7849      &        auxvec(1))
7850             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7851             if (j.eq.l+1) then
7852               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7853      &          b1(1,itj1),auxvec(1))
7854               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7855             else
7856               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7857      &          b1(1,itl1),auxvec(1))
7858               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7859             endif
7860             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7861      &        pizda(1,1))
7862             vv(1)=pizda(1,1)-pizda(2,2)
7863             vv(2)=pizda(2,1)+pizda(1,2)
7864             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7865             if (swap) then
7866               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7867 #ifdef MOMENT
7868                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7869      &             -(s1+s2+s4)
7870 #else
7871                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7872      &             -(s2+s4)
7873 #endif
7874                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7875               else
7876 #ifdef MOMENT
7877                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7878 #else
7879                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7880 #endif
7881                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7882               endif
7883             else
7884 #ifdef MOMENT
7885               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7886 #else
7887               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7888 #endif
7889               if (l.eq.j+1) then
7890                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7891               else
7892                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7893               endif
7894             endif
7895           enddo
7896         enddo
7897       enddo
7898       return
7899       end
7900 c----------------------------------------------------------------------------
7901       double precision function eello_turn6(i,jj,kk)
7902       implicit real*8 (a-h,o-z)
7903       include 'DIMENSIONS'
7904       include 'sizesclu.dat'
7905       include 'COMMON.IOUNITS'
7906       include 'COMMON.CHAIN'
7907       include 'COMMON.DERIV'
7908       include 'COMMON.INTERACT'
7909       include 'COMMON.CONTACTS'
7910       include 'COMMON.TORSION'
7911       include 'COMMON.VAR'
7912       include 'COMMON.GEO'
7913       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7914      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7915      &  ggg1(3),ggg2(3)
7916       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7917      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7918 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7919 C           the respective energy moment and not to the cluster cumulant.
7920       eello_turn6=0.0d0
7921       j=i+4
7922       k=i+1
7923       l=i+3
7924       iti=itortyp(itype(i))
7925       itk=itortyp(itype(k))
7926       itk1=itortyp(itype(k+1))
7927       itl=itortyp(itype(l))
7928       itj=itortyp(itype(j))
7929 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7930 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7931 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7932 cd        eello6=0.0d0
7933 cd        return
7934 cd      endif
7935 cd      write (iout,*)
7936 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7937 cd     &   ' and',k,l
7938 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7939       do iii=1,2
7940         do kkk=1,5
7941           do lll=1,3
7942             derx_turn(lll,kkk,iii)=0.0d0
7943           enddo
7944         enddo
7945       enddo
7946 cd      eij=1.0d0
7947 cd      ekl=1.0d0
7948 cd      ekont=1.0d0
7949       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7950 cd      eello6_5=0.0d0
7951 cd      write (2,*) 'eello6_5',eello6_5
7952 #ifdef MOMENT
7953       call transpose2(AEA(1,1,1),auxmat(1,1))
7954       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7955       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7956       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7957 #else
7958       s1 = 0.0d0
7959 #endif
7960       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7961       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7962       s2 = scalar2(b1(1,itk),vtemp1(1))
7963 #ifdef MOMENT
7964       call transpose2(AEA(1,1,2),atemp(1,1))
7965       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7966       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7967       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7968 #else
7969       s8=0.0d0
7970 #endif
7971       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7972       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7973       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7974 #ifdef MOMENT
7975       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7976       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7977       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7978       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7979       ss13 = scalar2(b1(1,itk),vtemp4(1))
7980       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7981 #else
7982       s13=0.0d0
7983 #endif
7984 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7985 c      s1=0.0d0
7986 c      s2=0.0d0
7987 c      s8=0.0d0
7988 c      s12=0.0d0
7989 c      s13=0.0d0
7990       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7991       if (calc_grad) then
7992 C Derivatives in gamma(i+2)
7993 #ifdef MOMENT
7994       call transpose2(AEA(1,1,1),auxmatd(1,1))
7995       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7996       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7997       call transpose2(AEAderg(1,1,2),atempd(1,1))
7998       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7999       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8000 #else
8001       s8d=0.0d0
8002 #endif
8003       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8004       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8005       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8006 c      s1d=0.0d0
8007 c      s2d=0.0d0
8008 c      s8d=0.0d0
8009 c      s12d=0.0d0
8010 c      s13d=0.0d0
8011       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8012 C Derivatives in gamma(i+3)
8013 #ifdef MOMENT
8014       call transpose2(AEA(1,1,1),auxmatd(1,1))
8015       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8016       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8017       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8018 #else
8019       s1d=0.0d0
8020 #endif
8021       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8022       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8023       s2d = scalar2(b1(1,itk),vtemp1d(1))
8024 #ifdef MOMENT
8025       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8026       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8027 #endif
8028       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8029 #ifdef MOMENT
8030       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8031       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8032       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8033 #else
8034       s13d=0.0d0
8035 #endif
8036 c      s1d=0.0d0
8037 c      s2d=0.0d0
8038 c      s8d=0.0d0
8039 c      s12d=0.0d0
8040 c      s13d=0.0d0
8041 #ifdef MOMENT
8042       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8043      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8044 #else
8045       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8046      &               -0.5d0*ekont*(s2d+s12d)
8047 #endif
8048 C Derivatives in gamma(i+4)
8049       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8050       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8051       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8052 #ifdef MOMENT
8053       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8054       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8055       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8056 #else
8057       s13d = 0.0d0
8058 #endif
8059 c      s1d=0.0d0
8060 c      s2d=0.0d0
8061 c      s8d=0.0d0
8062 C      s12d=0.0d0
8063 c      s13d=0.0d0
8064 #ifdef MOMENT
8065       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8066 #else
8067       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8068 #endif
8069 C Derivatives in gamma(i+5)
8070 #ifdef MOMENT
8071       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8072       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8073       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8074 #else
8075       s1d = 0.0d0
8076 #endif
8077       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8078       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8079       s2d = scalar2(b1(1,itk),vtemp1d(1))
8080 #ifdef MOMENT
8081       call transpose2(AEA(1,1,2),atempd(1,1))
8082       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8083       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8084 #else
8085       s8d = 0.0d0
8086 #endif
8087       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8088       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8089 #ifdef MOMENT
8090       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8091       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8092       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8093 #else
8094       s13d = 0.0d0
8095 #endif
8096 c      s1d=0.0d0
8097 c      s2d=0.0d0
8098 c      s8d=0.0d0
8099 c      s12d=0.0d0
8100 c      s13d=0.0d0
8101 #ifdef MOMENT
8102       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8103      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8104 #else
8105       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8106      &               -0.5d0*ekont*(s2d+s12d)
8107 #endif
8108 C Cartesian derivatives
8109       do iii=1,2
8110         do kkk=1,5
8111           do lll=1,3
8112 #ifdef MOMENT
8113             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8114             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8115             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8116 #else
8117             s1d = 0.0d0
8118 #endif
8119             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8120             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8121      &          vtemp1d(1))
8122             s2d = scalar2(b1(1,itk),vtemp1d(1))
8123 #ifdef MOMENT
8124             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8125             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8126             s8d = -(atempd(1,1)+atempd(2,2))*
8127      &           scalar2(cc(1,1,itl),vtemp2(1))
8128 #else
8129             s8d = 0.0d0
8130 #endif
8131             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8132      &           auxmatd(1,1))
8133             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8134             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8135 c      s1d=0.0d0
8136 c      s2d=0.0d0
8137 c      s8d=0.0d0
8138 c      s12d=0.0d0
8139 c      s13d=0.0d0
8140 #ifdef MOMENT
8141             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8142      &        - 0.5d0*(s1d+s2d)
8143 #else
8144             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8145      &        - 0.5d0*s2d
8146 #endif
8147 #ifdef MOMENT
8148             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8149      &        - 0.5d0*(s8d+s12d)
8150 #else
8151             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8152      &        - 0.5d0*s12d
8153 #endif
8154           enddo
8155         enddo
8156       enddo
8157 #ifdef MOMENT
8158       do kkk=1,5
8159         do lll=1,3
8160           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8161      &      achuj_tempd(1,1))
8162           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8163           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8164           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8165           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8166           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8167      &      vtemp4d(1))
8168           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8169           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8170           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8171         enddo
8172       enddo
8173 #endif
8174 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8175 cd     &  16*eel_turn6_num
8176 cd      goto 1112
8177       if (j.lt.nres-1) then
8178         j1=j+1
8179         j2=j-1
8180       else
8181         j1=j-1
8182         j2=j-2
8183       endif
8184       if (l.lt.nres-1) then
8185         l1=l+1
8186         l2=l-1
8187       else
8188         l1=l-1
8189         l2=l-2
8190       endif
8191       do ll=1,3
8192         ggg1(ll)=eel_turn6*g_contij(ll,1)
8193         ggg2(ll)=eel_turn6*g_contij(ll,2)
8194         ghalf=0.5d0*ggg1(ll)
8195 cd        ghalf=0.0d0
8196         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8197      &    +ekont*derx_turn(ll,2,1)
8198         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8199         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8200      &    +ekont*derx_turn(ll,4,1)
8201         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8202         ghalf=0.5d0*ggg2(ll)
8203 cd        ghalf=0.0d0
8204         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8205      &    +ekont*derx_turn(ll,2,2)
8206         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8207         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8208      &    +ekont*derx_turn(ll,4,2)
8209         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8210       enddo
8211 cd      goto 1112
8212       do m=i+1,j-1
8213         do ll=1,3
8214           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8215         enddo
8216       enddo
8217       do m=k+1,l-1
8218         do ll=1,3
8219           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8220         enddo
8221       enddo
8222 1112  continue
8223       do m=i+2,j2
8224         do ll=1,3
8225           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8226         enddo
8227       enddo
8228       do m=k+2,l2
8229         do ll=1,3
8230           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8231         enddo
8232       enddo
8233 cd      do iii=1,nres-3
8234 cd        write (2,*) iii,g_corr6_loc(iii)
8235 cd      enddo
8236       endif
8237       eello_turn6=ekont*eel_turn6
8238 cd      write (2,*) 'ekont',ekont
8239 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8240       return
8241       end
8242 crc-------------------------------------------------
8243       SUBROUTINE MATVEC2(A1,V1,V2)
8244       implicit real*8 (a-h,o-z)
8245       include 'DIMENSIONS'
8246       DIMENSION A1(2,2),V1(2),V2(2)
8247 c      DO 1 I=1,2
8248 c        VI=0.0
8249 c        DO 3 K=1,2
8250 c    3     VI=VI+A1(I,K)*V1(K)
8251 c        Vaux(I)=VI
8252 c    1 CONTINUE
8253
8254       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8255       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8256
8257       v2(1)=vaux1
8258       v2(2)=vaux2
8259       END
8260 C---------------------------------------
8261       SUBROUTINE MATMAT2(A1,A2,A3)
8262       implicit real*8 (a-h,o-z)
8263       include 'DIMENSIONS'
8264       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8265 c      DIMENSION AI3(2,2)
8266 c        DO  J=1,2
8267 c          A3IJ=0.0
8268 c          DO K=1,2
8269 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8270 c          enddo
8271 c          A3(I,J)=A3IJ
8272 c       enddo
8273 c      enddo
8274
8275       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8276       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8277       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8278       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8279
8280       A3(1,1)=AI3_11
8281       A3(2,1)=AI3_21
8282       A3(1,2)=AI3_12
8283       A3(2,2)=AI3_22
8284       END
8285
8286 c-------------------------------------------------------------------------
8287       double precision function scalar2(u,v)
8288       implicit none
8289       double precision u(2),v(2)
8290       double precision sc
8291       integer i
8292       scalar2=u(1)*v(1)+u(2)*v(2)
8293       return
8294       end
8295
8296 C-----------------------------------------------------------------------------
8297
8298       subroutine transpose2(a,at)
8299       implicit none
8300       double precision a(2,2),at(2,2)
8301       at(1,1)=a(1,1)
8302       at(1,2)=a(2,1)
8303       at(2,1)=a(1,2)
8304       at(2,2)=a(2,2)
8305       return
8306       end
8307 c--------------------------------------------------------------------------
8308       subroutine transpose(n,a,at)
8309       implicit none
8310       integer n,i,j
8311       double precision a(n,n),at(n,n)
8312       do i=1,n
8313         do j=1,n
8314           at(j,i)=a(i,j)
8315         enddo
8316       enddo
8317       return
8318       end
8319 C---------------------------------------------------------------------------
8320       subroutine prodmat3(a1,a2,kk,transp,prod)
8321       implicit none
8322       integer i,j
8323       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8324       logical transp
8325 crc      double precision auxmat(2,2),prod_(2,2)
8326
8327       if (transp) then
8328 crc        call transpose2(kk(1,1),auxmat(1,1))
8329 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8330 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8331
8332            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8333      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8334            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8335      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8336            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8337      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8338            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8339      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8340
8341       else
8342 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8343 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8344
8345            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8346      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8347            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8348      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8349            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8350      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8351            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8352      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8353
8354       endif
8355 c      call transpose2(a2(1,1),a2t(1,1))
8356
8357 crc      print *,transp
8358 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8359 crc      print *,((prod(i,j),i=1,2),j=1,2)
8360
8361       return
8362       end
8363 C-----------------------------------------------------------------------------
8364       double precision function scalar(u,v)
8365       implicit none
8366       double precision u(3),v(3)
8367       double precision sc
8368       integer i
8369       sc=0.0d0
8370       do i=1,3
8371         sc=sc+u(i)*v(i)
8372       enddo
8373       scalar=sc
8374       return
8375       end
8376 C-----------------------------------------------------------------------
8377       double precision function sscale(r)
8378       double precision r,gamm
8379       include "COMMON.SPLITELE"
8380       if(r.lt.r_cut-rlamb) then
8381         sscale=1.0d0
8382       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8383         gamm=(r-(r_cut-rlamb))/rlamb
8384         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8385       else
8386         sscale=0d0
8387       endif
8388       return
8389       end
8390 C-----------------------------------------------------------------------
8391 C-----------------------------------------------------------------------
8392       double precision function sscagrad(r)
8393       double precision r,gamm
8394       include "COMMON.SPLITELE"
8395       if(r.lt.r_cut-rlamb) then
8396         sscagrad=0.0d0
8397       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8398         gamm=(r-(r_cut-rlamb))/rlamb
8399         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8400       else
8401         sscagrad=0.0d0
8402       endif
8403       return
8404       end
8405 C-----------------------------------------------------------------------
8406 C first for shielding is setting of function of side-chains
8407        subroutine set_shield_fac2
8408       implicit real*8 (a-h,o-z)
8409       include 'DIMENSIONS'
8410       include 'COMMON.CHAIN'
8411       include 'COMMON.DERIV'
8412       include 'COMMON.IOUNITS'
8413       include 'COMMON.SHIELD'
8414       include 'COMMON.INTERACT'
8415 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8416       double precision div77_81/0.974996043d0/,
8417      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8418
8419 C the vector between center of side_chain and peptide group
8420        double precision pep_side(3),long,side_calf(3),
8421      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8422      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8423 C the line belowe needs to be changed for FGPROC>1
8424       do i=1,nres-1
8425       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8426       ishield_list(i)=0
8427 Cif there two consequtive dummy atoms there is no peptide group between them
8428 C the line below has to be changed for FGPROC>1
8429       VolumeTotal=0.0
8430       do k=1,nres
8431        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8432        dist_pep_side=0.0
8433        dist_side_calf=0.0
8434        do j=1,3
8435 C first lets set vector conecting the ithe side-chain with kth side-chain
8436       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8437 C      pep_side(j)=2.0d0
8438 C and vector conecting the side-chain with its proper calfa
8439       side_calf(j)=c(j,k+nres)-c(j,k)
8440 C      side_calf(j)=2.0d0
8441       pept_group(j)=c(j,i)-c(j,i+1)
8442 C lets have their lenght
8443       dist_pep_side=pep_side(j)**2+dist_pep_side
8444       dist_side_calf=dist_side_calf+side_calf(j)**2
8445       dist_pept_group=dist_pept_group+pept_group(j)**2
8446       enddo
8447        dist_pep_side=dsqrt(dist_pep_side)
8448        dist_pept_group=dsqrt(dist_pept_group)
8449        dist_side_calf=dsqrt(dist_side_calf)
8450       do j=1,3
8451         pep_side_norm(j)=pep_side(j)/dist_pep_side
8452         side_calf_norm(j)=dist_side_calf
8453       enddo
8454 C now sscale fraction
8455        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8456 C       print *,buff_shield,"buff"
8457 C now sscale
8458         if (sh_frac_dist.le.0.0) cycle
8459 C If we reach here it means that this side chain reaches the shielding sphere
8460 C Lets add him to the list for gradient
8461         ishield_list(i)=ishield_list(i)+1
8462 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8463 C this list is essential otherwise problem would be O3
8464         shield_list(ishield_list(i),i)=k
8465 C Lets have the sscale value
8466         if (sh_frac_dist.gt.1.0) then
8467          scale_fac_dist=1.0d0
8468          do j=1,3
8469          sh_frac_dist_grad(j)=0.0d0
8470          enddo
8471         else
8472          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8473      &                   *(2.0d0*sh_frac_dist-3.0d0)
8474          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8475      &                  /dist_pep_side/buff_shield*0.5d0
8476 C remember for the final gradient multiply sh_frac_dist_grad(j)
8477 C for side_chain by factor -2 !
8478          do j=1,3
8479          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8480 C         sh_frac_dist_grad(j)=0.0d0
8481 C         scale_fac_dist=1.0d0
8482 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8483 C     &                    sh_frac_dist_grad(j)
8484          enddo
8485         endif
8486 C this is what is now we have the distance scaling now volume...
8487       short=short_r_sidechain(itype(k))
8488       long=long_r_sidechain(itype(k))
8489       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8490       sinthet=short/dist_pep_side*costhet
8491 C now costhet_grad
8492 C       costhet=0.6d0
8493 C       sinthet=0.8
8494        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8495 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8496 C     &             -short/dist_pep_side**2/costhet)
8497 C       costhet_fac=0.0d0
8498        do j=1,3
8499          costhet_grad(j)=costhet_fac*pep_side(j)
8500        enddo
8501 C remember for the final gradient multiply costhet_grad(j)
8502 C for side_chain by factor -2 !
8503 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8504 C pep_side0pept_group is vector multiplication
8505       pep_side0pept_group=0.0d0
8506       do j=1,3
8507       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8508       enddo
8509       cosalfa=(pep_side0pept_group/
8510      & (dist_pep_side*dist_side_calf))
8511       fac_alfa_sin=1.0d0-cosalfa**2
8512       fac_alfa_sin=dsqrt(fac_alfa_sin)
8513       rkprim=fac_alfa_sin*(long-short)+short
8514 C      rkprim=short
8515
8516 C now costhet_grad
8517        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8518 C       cosphi=0.6
8519        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8520        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8521      &      dist_pep_side**2)
8522 C       sinphi=0.8
8523        do j=1,3
8524          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8525      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8526      &*(long-short)/fac_alfa_sin*cosalfa/
8527      &((dist_pep_side*dist_side_calf))*
8528      &((side_calf(j))-cosalfa*
8529      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8530 C       cosphi_grad_long(j)=0.0d0
8531         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8532      &*(long-short)/fac_alfa_sin*cosalfa
8533      &/((dist_pep_side*dist_side_calf))*
8534      &(pep_side(j)-
8535      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8536 C       cosphi_grad_loc(j)=0.0d0
8537        enddo
8538 C      print *,sinphi,sinthet
8539       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8540      &                    /VSolvSphere_div
8541 C     &                    *wshield
8542 C now the gradient...
8543       do j=1,3
8544       grad_shield(j,i)=grad_shield(j,i)
8545 C gradient po skalowaniu
8546      &                +(sh_frac_dist_grad(j)*VofOverlap
8547 C  gradient po costhet
8548      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.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 C grad_shield_side is Cbeta sidechain gradient
8554       grad_shield_side(j,ishield_list(i),i)=
8555      &        (sh_frac_dist_grad(j)*-2.0d0
8556      &        *VofOverlap
8557      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8558      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8559      &       sinphi/sinthet*costhet*costhet_grad(j)
8560      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8561      &       )*wshield
8562
8563        grad_shield_loc(j,ishield_list(i),i)=
8564      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8565      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8566      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8567      &        ))
8568      &        *wshield
8569       enddo
8570       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8571       enddo
8572       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8573 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8574       enddo
8575       return
8576       end
8577 C first for shielding is setting of function of side-chains
8578        subroutine set_shield_fac
8579       implicit real*8 (a-h,o-z)
8580       include 'DIMENSIONS'
8581       include 'COMMON.CHAIN'
8582       include 'COMMON.DERIV'
8583       include 'COMMON.IOUNITS'
8584       include 'COMMON.SHIELD'
8585       include 'COMMON.INTERACT'
8586 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8587       double precision div77_81/0.974996043d0/,
8588      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8589
8590 C the vector between center of side_chain and peptide group
8591        double precision pep_side(3),long,side_calf(3),
8592      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8593      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8594 C the line belowe needs to be changed for FGPROC>1
8595       do i=1,nres-1
8596       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8597       ishield_list(i)=0
8598 Cif there two consequtive dummy atoms there is no peptide group between them
8599 C the line below has to be changed for FGPROC>1
8600       VolumeTotal=0.0
8601       do k=1,nres
8602        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8603        dist_pep_side=0.0
8604        dist_side_calf=0.0
8605        do j=1,3
8606 C first lets set vector conecting the ithe side-chain with kth side-chain
8607       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8608 C      pep_side(j)=2.0d0
8609 C and vector conecting the side-chain with its proper calfa
8610       side_calf(j)=c(j,k+nres)-c(j,k)
8611 C      side_calf(j)=2.0d0
8612       pept_group(j)=c(j,i)-c(j,i+1)
8613 C lets have their lenght
8614       dist_pep_side=pep_side(j)**2+dist_pep_side
8615       dist_side_calf=dist_side_calf+side_calf(j)**2
8616       dist_pept_group=dist_pept_group+pept_group(j)**2
8617       enddo
8618        dist_pep_side=dsqrt(dist_pep_side)
8619        dist_pept_group=dsqrt(dist_pept_group)
8620        dist_side_calf=dsqrt(dist_side_calf)
8621       do j=1,3
8622         pep_side_norm(j)=pep_side(j)/dist_pep_side
8623         side_calf_norm(j)=dist_side_calf
8624       enddo
8625 C now sscale fraction
8626        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8627 C       print *,buff_shield,"buff"
8628 C now sscale
8629         if (sh_frac_dist.le.0.0) cycle
8630 C If we reach here it means that this side chain reaches the shielding sphere
8631 C Lets add him to the list for gradient
8632         ishield_list(i)=ishield_list(i)+1
8633 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8634 C this list is essential otherwise problem would be O3
8635         shield_list(ishield_list(i),i)=k
8636 C Lets have the sscale value
8637         if (sh_frac_dist.gt.1.0) then
8638          scale_fac_dist=1.0d0
8639          do j=1,3
8640          sh_frac_dist_grad(j)=0.0d0
8641          enddo
8642         else
8643          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8644      &                   *(2.0*sh_frac_dist-3.0d0)
8645          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8646      &                  /dist_pep_side/buff_shield*0.5
8647 C remember for the final gradient multiply sh_frac_dist_grad(j)
8648 C for side_chain by factor -2 !
8649          do j=1,3
8650          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8651 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8652 C     &                    sh_frac_dist_grad(j)
8653          enddo
8654         endif
8655 C        if ((i.eq.3).and.(k.eq.2)) then
8656 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8657 C     & ,"TU"
8658 C        endif
8659
8660 C this is what is now we have the distance scaling now volume...
8661       short=short_r_sidechain(itype(k))
8662       long=long_r_sidechain(itype(k))
8663       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8664 C now costhet_grad
8665 C       costhet=0.0d0
8666        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8667 C       costhet_fac=0.0d0
8668        do j=1,3
8669          costhet_grad(j)=costhet_fac*pep_side(j)
8670        enddo
8671 C remember for the final gradient multiply costhet_grad(j)
8672 C for side_chain by factor -2 !
8673 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8674 C pep_side0pept_group is vector multiplication
8675       pep_side0pept_group=0.0
8676       do j=1,3
8677       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8678       enddo
8679       cosalfa=(pep_side0pept_group/
8680      & (dist_pep_side*dist_side_calf))
8681       fac_alfa_sin=1.0-cosalfa**2
8682       fac_alfa_sin=dsqrt(fac_alfa_sin)
8683       rkprim=fac_alfa_sin*(long-short)+short
8684 C now costhet_grad
8685        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8686        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8687
8688        do j=1,3
8689          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8690      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8691      &*(long-short)/fac_alfa_sin*cosalfa/
8692      &((dist_pep_side*dist_side_calf))*
8693      &((side_calf(j))-cosalfa*
8694      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8695
8696         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8697      &*(long-short)/fac_alfa_sin*cosalfa
8698      &/((dist_pep_side*dist_side_calf))*
8699      &(pep_side(j)-
8700      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8701        enddo
8702
8703       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8704      &                    /VSolvSphere_div
8705      &                    *wshield
8706 C now the gradient...
8707 C grad_shield is gradient of Calfa for peptide groups
8708 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8709 C     &               costhet,cosphi
8710 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8711 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8712       do j=1,3
8713       grad_shield(j,i)=grad_shield(j,i)
8714 C gradient po skalowaniu
8715      &                +(sh_frac_dist_grad(j)
8716 C  gradient po costhet
8717      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8718      &-scale_fac_dist*(cosphi_grad_long(j))
8719      &/(1.0-cosphi) )*div77_81
8720      &*VofOverlap
8721 C grad_shield_side is Cbeta sidechain gradient
8722       grad_shield_side(j,ishield_list(i),i)=
8723      &        (sh_frac_dist_grad(j)*-2.0d0
8724      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8725      &       +scale_fac_dist*(cosphi_grad_long(j))
8726      &        *2.0d0/(1.0-cosphi))
8727      &        *div77_81*VofOverlap
8728
8729        grad_shield_loc(j,ishield_list(i),i)=
8730      &   scale_fac_dist*cosphi_grad_loc(j)
8731      &        *2.0d0/(1.0-cosphi)
8732      &        *div77_81*VofOverlap
8733       enddo
8734       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8735       enddo
8736       fac_shield(i)=VolumeTotal*div77_81+div4_81
8737 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8738       enddo
8739       return
8740       end
8741 C--------------------------------------------------------------------------
8742