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
 100       if (wliptran.gt.0) then
 101         call Eliptransfer(eliptran)
 102       endif
 103
 104 C
 105 C 12/1/95 Multi-body terms
 106 C
 107       n_corr=0
 108       n_corr1=0
 109       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 110      &    .or. wturn6.gt.0.0d0) then
 111 c         print *,"calling multibody_eello"
 112          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 113 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 114 c         print *,ecorr,ecorr5,ecorr6,eturn6
 115       endif
 116       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 117          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 118       endif
 119       write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 120 #ifdef SPLITELE
 121       if (shield_mode.gt.0) then
 122       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 123      & +welec*fact(1)*ees
 124      & +fact(1)*wvdwpp*evdw1
 125      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 126      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 127      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 128      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 129      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 130      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 131      & +wliptran*eliptran
 132       else
 133       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 134      & +wvdwpp*evdw1
 135      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 136      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 137      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 138      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 139      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 140      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 141      & +wliptran*eliptran
 142       endif
 143 #else
 144       if (shield_mode.gt.0) then
 145       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 146      & +welec*fact(1)*(ees+evdw1)
 147      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 148      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 149      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 150      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 151      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 152      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 153      & +wliptran*eliptran
 154       else
 155       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 156      & +welec*fact(1)*(ees+evdw1)
 157      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 158      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 159      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 160      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 161      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 162      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 163      & +wliptran*eliptran
 164       endif
 165 #endif
 166
 167       energia(0)=etot
 168       energia(1)=evdw
 169 #ifdef SCP14
 170       energia(2)=evdw2-evdw2_14
 171       energia(17)=evdw2_14
 172 #else
 173       energia(2)=evdw2
 174       energia(17)=0.0d0
 175 #endif
 176 #ifdef SPLITELE
 177       energia(3)=ees
 178       energia(16)=evdw1
 179 #else
 180       energia(3)=ees+evdw1
 181       energia(16)=0.0d0
 182 #endif
 183       energia(4)=ecorr
 184       energia(5)=ecorr5
 185       energia(6)=ecorr6
 186       energia(7)=eel_loc
 187       energia(8)=eello_turn3
 188       energia(9)=eello_turn4
 189       energia(10)=eturn6
 190       energia(11)=ebe
 191       energia(12)=escloc
 192       energia(13)=etors
 193       energia(14)=etors_d
 194       energia(15)=ehpb
 195       energia(18)=estr
 196       energia(19)=esccor
 197       energia(20)=edihcnstr
 198       energia(21)=evdw_t
 199       energia(24)=ethetacnstr
 200       energia(22)=eliptran
 201 c detecting NaNQ
 202 #ifdef ISNAN
 203 #ifdef AIX
 204       if (isnan(etot).ne.0) energia(0)=1.0d+99
 205 #else
 206       if (isnan(etot)) energia(0)=1.0d+99
 207 #endif
 208 #else
 209       i=0
 210 #ifdef WINPGI
 211       idumm=proc_proc(etot,i)
 212 #else
 213       call proc_proc(etot,i)
 214 #endif
 215       if(i.eq.1)energia(0)=1.0d+99
 216 #endif
 217 #ifdef MPL
 218 c     endif
 219 #endif
 220       if (calc_grad) then
 221 C
 222 C Sum up the components of the Cartesian gradient.
 223 C
 224 #ifdef SPLITELE
 225       do i=1,nct
 226         do j=1,3
 227       if (shield_mode.eq.0) then
 228           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 229      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 230      &                wbond*gradb(j,i)+
 231      &                wstrain*ghpbc(j,i)+
 232      &                wcorr*fact(3)*gradcorr(j,i)+
 233      &                wel_loc*fact(2)*gel_loc(j,i)+
 234      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 235      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 236      &                wcorr5*fact(4)*gradcorr5(j,i)+
 237      &                wcorr6*fact(5)*gradcorr6(j,i)+
 238      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 239      &                wsccor*fact(2)*gsccorc(j,i)
 240      &               +wliptran*gliptranc(j,i)
 241           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 242      &                  wbond*gradbx(j,i)+
 243      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 244      &                  wsccor*fact(2)*gsccorx(j,i)
 245      &                 +wliptran*gliptranx(j,i)
 246         else
 247           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 248      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 249      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 250      &                wbond*gradb(j,i)+
 251      &                wstrain*ghpbc(j,i)+
 252      &                wcorr*fact(3)*gradcorr(j,i)+
 253      &                wel_loc*fact(2)*gel_loc(j,i)+
 254      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 255      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 256      &                wcorr5*fact(4)*gradcorr5(j,i)+
 257      &                wcorr6*fact(5)*gradcorr6(j,i)+
 258      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 259      &                wsccor*fact(2)*gsccorc(j,i)
 260      &               +wliptran*gliptranc(j,i)
 261      &                 +welec*gshieldc(j,i)
 262      &                 +welec*gshieldc_loc(j,i)
 263      &                 +wcorr*gshieldc_ec(j,i)
 264      &                 +wcorr*gshieldc_loc_ec(j,i)
 265      &                 +wturn3*gshieldc_t3(j,i)
 266      &                 +wturn3*gshieldc_loc_t3(j,i)
 267      &                 +wturn4*gshieldc_t4(j,i)
 268      &                 +wturn4*gshieldc_loc_t4(j,i)
 269      &                 +wel_loc*gshieldc_ll(j,i)
 270      &                 +wel_loc*gshieldc_loc_ll(j,i)
 271
 272           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 273      &                 +fact(1)*wscp*gradx_scp(j,i)+
 274      &                  wbond*gradbx(j,i)+
 275      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 276      &                  wsccor*fact(2)*gsccorx(j,i)
 277      &                 +wliptran*gliptranx(j,i)
 278      &                 +welec*gshieldx(j,i)
 279      &                 +wcorr*gshieldx_ec(j,i)
 280      &                 +wturn3*gshieldx_t3(j,i)
 281      &                 +wturn4*gshieldx_t4(j,i)
 282      &                 +wel_loc*gshieldx_ll(j,i)
 283
 284
 285         endif
 286         enddo
 287 #else
 288        do i=1,nct
 289         do j=1,3
 290                 if (shield_mode.eq.0) then
 291           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 292      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 293      &                wbond*gradb(j,i)+
 294      &                wcorr*fact(3)*gradcorr(j,i)+
 295      &                wel_loc*fact(2)*gel_loc(j,i)+
 296      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 297      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 298      &                wcorr5*fact(4)*gradcorr5(j,i)+
 299      &                wcorr6*fact(5)*gradcorr6(j,i)+
 300      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 301      &                wsccor*fact(2)*gsccorc(j,i)
 302      &               +wliptran*gliptranc(j,i)
 303           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 304      &                  wbond*gradbx(j,i)+
 305      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 306      &                  wsccor*fact(1)*gsccorx(j,i)
 307      &                 +wliptran*gliptranx(j,i)
 308               else
 309           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 310      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 311      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 312      &                wbond*gradb(j,i)+
 313      &                wcorr*fact(3)*gradcorr(j,i)+
 314      &                wel_loc*fact(2)*gel_loc(j,i)+
 315      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 316      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 317      &                wcorr5*fact(4)*gradcorr5(j,i)+
 318      &                wcorr6*fact(5)*gradcorr6(j,i)+
 319      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 320      &                wsccor*fact(2)*gsccorc(j,i)
 321      &               +wliptran*gliptranc(j,i)
 322           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 323      &                  fact(1)*wscp*gradx_scp(j,i)+
 324      &                  wbond*gradbx(j,i)+
 325      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 326      &                  wsccor*fact(1)*gsccorx(j,i)
 327      &                 +wliptran*gliptranx(j,i)
 328          endif
 329         enddo
 330 #endif
 331       enddo
 332
 333
 334       do i=1,nres-3
 335         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 336      &   +wcorr5*fact(4)*g_corr5_loc(i)
 337      &   +wcorr6*fact(5)*g_corr6_loc(i)
 338      &   +wturn4*fact(3)*gel_loc_turn4(i)
 339      &   +wturn3*fact(2)*gel_loc_turn3(i)
 340      &   +wturn6*fact(5)*gel_loc_turn6(i)
 341      &   +wel_loc*fact(2)*gel_loc_loc(i)
 342 c     &   +wsccor*fact(1)*gsccor_loc(i)
 343 c ROZNICA Z WHAMem
 344       enddo
 345       endif
 346       if (dyn_ss) call dyn_set_nss
 347       return
 348       end
 349 C------------------------------------------------------------------------
 350       subroutine enerprint(energia,fact)
 351       implicit real*8 (a-h,o-z)
 352       include 'DIMENSIONS'
 353       include 'sizesclu.dat'
 354       include 'COMMON.IOUNITS'
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.SBRIDGE'
 357       double precision energia(0:max_ene),fact(6)
 358       etot=energia(0)
 359       evdw=energia(1)+fact(6)*energia(21)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(17)
 362 #else
 363       evdw2=energia(2)
 364 #endif
 365       ees=energia(3)
 366 #ifdef SPLITELE
 367       evdw1=energia(16)
 368 #endif
 369       ecorr=energia(4)
 370       ecorr5=energia(5)
 371       ecorr6=energia(6)
 372       eel_loc=energia(7)
 373       eello_turn3=energia(8)
 374       eello_turn4=energia(9)
 375       eello_turn6=energia(10)
 376       ebe=energia(11)
 377       escloc=energia(12)
 378       etors=energia(13)
 379       etors_d=energia(14)
 380       ehpb=energia(15)
 381       esccor=energia(19)
 382       edihcnstr=energia(20)
 383       estr=energia(18)
 384       ethetacnstr=energia(24)
 385 #ifdef SPLITELE
 386       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 387      &  wvdwpp,
 388      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 389      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 390      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 391      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 392      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 393      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 394    10 format (/'Virtual-chain energies:'//
 395      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 396      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 397      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 398      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 399      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 400      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 401      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 402      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 403      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 404      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 405      & ' (SS bridges & dist. cnstr.)'/
 406      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 407      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 408      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 409      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 410      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 411      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 412      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 413      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 414      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 415      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 416      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 417      & 'ETOT=  ',1pE16.6,' (total)')
 418 #else
 419       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 420      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 421      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 422      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 423      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 424      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 425      &  edihcnstr,ethetacnstr,ebr*nss,etot
 426    10 format (/'Virtual-chain energies:'//
 427      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 428      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 429      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 430      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 431      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 432      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 433      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 434      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 435      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 436      & ' (SS bridges & dist. cnstr.)'/
 437      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 438      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 439      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 440      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 441      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 442      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 443      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 444      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 445      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 446      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 447      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 448      & 'ETOT=  ',1pE16.6,' (total)')
 449 #endif
 450       return
 451       end
 452 C-----------------------------------------------------------------------
 453       subroutine elj(evdw,evdw_t)
 454 C
 455 C This subroutine calculates the interaction energy of nonbonded side chains
 456 C assuming the LJ potential of interaction.
 457 C
 458       implicit real*8 (a-h,o-z)
 459       include 'DIMENSIONS'
 460       include 'sizesclu.dat'
 461       include "DIMENSIONS.COMPAR"
 462       parameter (accur=1.0d-10)
 463       include 'COMMON.GEO'
 464       include 'COMMON.VAR'
 465       include 'COMMON.LOCAL'
 466       include 'COMMON.CHAIN'
 467       include 'COMMON.DERIV'
 468       include 'COMMON.INTERACT'
 469       include 'COMMON.TORSION'
 470       include 'COMMON.SBRIDGE'
 471       include 'COMMON.NAMES'
 472       include 'COMMON.IOUNITS'
 473       include 'COMMON.CONTACTS'
 474       dimension gg(3)
 475       integer icant
 476       external icant
 477 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 478 c ROZNICA DODANE Z WHAM
 479 c      do i=1,210
 480 c        do j=1,2
 481 c          eneps_temp(j,i)=0.0d0
 482 c        enddo
 483 c      enddo
 484 cROZNICA
 485
 486       evdw=0.0D0
 487       evdw_t=0.0d0
 488       do i=iatsc_s,iatsc_e
 489         itypi=iabs(itype(i))
 490         if (itypi.eq.ntyp1) cycle
 491         itypi1=iabs(itype(i+1))
 492         xi=c(1,nres+i)
 493         yi=c(2,nres+i)
 494         zi=c(3,nres+i)
 495 C Change 12/1/95
 496         num_conti=0
 497 C
 498 C Calculate SC interaction energy.
 499 C
 500         do iint=1,nint_gr(i)
 501 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 502 cd   &                  'iend=',iend(i,iint)
 503           do j=istart(i,iint),iend(i,iint)
 504             itypj=iabs(itype(j))
 505             if (itypj.eq.ntyp1) cycle
 506             xj=c(1,nres+j)-xi
 507             yj=c(2,nres+j)-yi
 508             zj=c(3,nres+j)-zi
 509 C Change 12/1/95 to calculate four-body interactions
 510             rij=xj*xj+yj*yj+zj*zj
 511             rrij=1.0D0/rij
 512 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 513             eps0ij=eps(itypi,itypj)
 514             fac=rrij**expon2
 515             e1=fac*fac*aa
 516             e2=fac*bb
 517             evdwij=e1+e2
 518             ij=icant(itypi,itypj)
 519 c ROZNICA z WHAM
 520 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 521 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 522 c
 523
 524 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 525 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 526 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 527 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 528 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 529 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 530             if (bb.gt.0.0d0) then
 531               evdw=evdw+evdwij
 532             else
 533               evdw_t=evdw_t+evdwij
 534             endif
 535             if (calc_grad) then
 536 C
 537 C Calculate the components of the gradient in DC and X
 538 C
 539             fac=-rrij*(e1+evdwij)
 540             gg(1)=xj*fac
 541             gg(2)=yj*fac
 542             gg(3)=zj*fac
 543             do k=1,3
 544               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 545               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 546             enddo
 547             do k=i,j-1
 548               do l=1,3
 549                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 550               enddo
 551             enddo
 552             endif
 553 C
 554 C 12/1/95, revised on 5/20/97
 555 C
 556 C Calculate the contact function. The ith column of the array JCONT will
 557 C contain the numbers of atoms that make contacts with the atom I (of numbers
 558 C greater than I). The arrays FACONT and GACONT will contain the values of
 559 C the contact function and its derivative.
 560 C
 561 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 562 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 563 C Uncomment next line, if the correlation interactions are contact function only
 564             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 565               rij=dsqrt(rij)
 566               sigij=sigma(itypi,itypj)
 567               r0ij=rs0(itypi,itypj)
 568 C
 569 C Check whether the SC's are not too far to make a contact.
 570 C
 571               rcut=1.5d0*r0ij
 572               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 573 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 574 C
 575               if (fcont.gt.0.0D0) then
 576 C If the SC-SC distance if close to sigma, apply spline.
 577 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 578 cAdam &             fcont1,fprimcont1)
 579 cAdam           fcont1=1.0d0-fcont1
 580 cAdam           if (fcont1.gt.0.0d0) then
 581 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 582 cAdam             fcont=fcont*fcont1
 583 cAdam           endif
 584 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 585 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 586 cga             do k=1,3
 587 cga               gg(k)=gg(k)*eps0ij
 588 cga             enddo
 589 cga             eps0ij=-evdwij*eps0ij
 590 C Uncomment for AL's type of SC correlation interactions.
 591 cadam           eps0ij=-evdwij
 592                 num_conti=num_conti+1
 593                 jcont(num_conti,i)=j
 594                 facont(num_conti,i)=fcont*eps0ij
 595                 fprimcont=eps0ij*fprimcont/rij
 596                 fcont=expon*fcont
 597 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 598 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 599 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 600 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 601                 gacont(1,num_conti,i)=-fprimcont*xj
 602                 gacont(2,num_conti,i)=-fprimcont*yj
 603                 gacont(3,num_conti,i)=-fprimcont*zj
 604 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 605 cd              write (iout,'(2i3,3f10.5)')
 606 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 607               endif
 608             endif
 609           enddo      ! j
 610         enddo        ! iint
 611 C Change 12/1/95
 612         num_cont(i)=num_conti
 613       enddo          ! i
 614       if (calc_grad) then
 615       do i=1,nct
 616         do j=1,3
 617           gvdwc(j,i)=expon*gvdwc(j,i)
 618           gvdwx(j,i)=expon*gvdwx(j,i)
 619         enddo
 620       enddo
 621       endif
 622 C******************************************************************************
 623 C
 624 C                              N O T E !!!
 625 C
 626 C To save time, the factor of EXPON has been extracted from ALL components
 627 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 628 C use!
 629 C
 630 C******************************************************************************
 631       return
 632       end
 633 C-----------------------------------------------------------------------------
 634       subroutine eljk(evdw,evdw_t)
 635 C
 636 C This subroutine calculates the interaction energy of nonbonded side chains
 637 C assuming the LJK potential of interaction.
 638 C
 639       implicit real*8 (a-h,o-z)
 640       include 'DIMENSIONS'
 641       include 'sizesclu.dat'
 642       include "DIMENSIONS.COMPAR"
 643       include 'COMMON.GEO'
 644       include 'COMMON.VAR'
 645       include 'COMMON.LOCAL'
 646       include 'COMMON.CHAIN'
 647       include 'COMMON.DERIV'
 648       include 'COMMON.INTERACT'
 649       include 'COMMON.IOUNITS'
 650       include 'COMMON.NAMES'
 651       dimension gg(3)
 652       logical scheck
 653       integer icant
 654       external icant
 655 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 656       evdw=0.0D0
 657       evdw_t=0.0d0
 658       do i=iatsc_s,iatsc_e
 659         itypi=iabs(itype(i))
 660         if (itypi.eq.ntyp1) cycle
 661         itypi1=iabs(itype(i+1))
 662         xi=c(1,nres+i)
 663         yi=c(2,nres+i)
 664         zi=c(3,nres+i)
 665 C
 666 C Calculate SC interaction energy.
 667 C
 668         do iint=1,nint_gr(i)
 669           do j=istart(i,iint),iend(i,iint)
 670             itypj=iabs(itype(j))
 671             if (itypj.eq.ntyp1) cycle
 672             xj=c(1,nres+j)-xi
 673             yj=c(2,nres+j)-yi
 674             zj=c(3,nres+j)-zi
 675             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 676             fac_augm=rrij**expon
 677             e_augm=augm(itypi,itypj)*fac_augm
 678             r_inv_ij=dsqrt(rrij)
 679             rij=1.0D0/r_inv_ij
 680             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 681             fac=r_shift_inv**expon
 682             e1=fac*fac*aa
 683             e2=fac*bb
 684             evdwij=e_augm+e1+e2
 685             ij=icant(itypi,itypj)
 686 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 687 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 688 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 689 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 690 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 691 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 692 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 693             if (bb.gt.0.0d0) then
 694               evdw=evdw+evdwij
 695             else
 696               evdw_t=evdw_t+evdwij
 697             endif
 698             if (calc_grad) then
 699 C
 700 C Calculate the components of the gradient in DC and X
 701 C
 702             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 703             gg(1)=xj*fac
 704             gg(2)=yj*fac
 705             gg(3)=zj*fac
 706             do k=1,3
 707               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 708               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 709             enddo
 710             do k=i,j-1
 711               do l=1,3
 712                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 713               enddo
 714             enddo
 715             endif
 716           enddo      ! j
 717         enddo        ! iint
 718       enddo          ! i
 719       if (calc_grad) then
 720       do i=1,nct
 721         do j=1,3
 722           gvdwc(j,i)=expon*gvdwc(j,i)
 723           gvdwx(j,i)=expon*gvdwx(j,i)
 724         enddo
 725       enddo
 726       endif
 727       return
 728       end
 729 C-----------------------------------------------------------------------------
 730       subroutine ebp(evdw,evdw_t)
 731 C
 732 C This subroutine calculates the interaction energy of nonbonded side chains
 733 C assuming the Berne-Pechukas potential of interaction.
 734 C
 735       implicit real*8 (a-h,o-z)
 736       include 'DIMENSIONS'
 737       include 'sizesclu.dat'
 738       include "DIMENSIONS.COMPAR"
 739       include 'COMMON.GEO'
 740       include 'COMMON.VAR'
 741       include 'COMMON.LOCAL'
 742       include 'COMMON.CHAIN'
 743       include 'COMMON.DERIV'
 744       include 'COMMON.NAMES'
 745       include 'COMMON.INTERACT'
 746       include 'COMMON.IOUNITS'
 747       include 'COMMON.CALC'
 748       common /srutu/ icall
 749 c     double precision rrsave(maxdim)
 750       logical lprn
 751       integer icant
 752       external icant
 753       evdw=0.0D0
 754       evdw_t=0.0d0
 755 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 756 c     if (icall.eq.0) then
 757 c       lprn=.true.
 758 c     else
 759         lprn=.false.
 760 c     endif
 761       ind=0
 762       do i=iatsc_s,iatsc_e
 763         itypi=iabs(itype(i))
 764         if (itypi.eq.ntyp1) cycle
 765         itypi1=iabs(itype(i+1))
 766         xi=c(1,nres+i)
 767         yi=c(2,nres+i)
 768         zi=c(3,nres+i)
 769         dxi=dc_norm(1,nres+i)
 770         dyi=dc_norm(2,nres+i)
 771         dzi=dc_norm(3,nres+i)
 772         dsci_inv=vbld_inv(i+nres)
 773 C
 774 C Calculate SC interaction energy.
 775 C
 776         do iint=1,nint_gr(i)
 777           do j=istart(i,iint),iend(i,iint)
 778             ind=ind+1
 779             itypj=iabs(itype(j))
 780             if (itypj.eq.ntyp1) cycle
 781             dscj_inv=vbld_inv(j+nres)
 782             chi1=chi(itypi,itypj)
 783             chi2=chi(itypj,itypi)
 784             chi12=chi1*chi2
 785             chip1=chip(itypi)
 786             chip2=chip(itypj)
 787             chip12=chip1*chip2
 788             alf1=alp(itypi)
 789             alf2=alp(itypj)
 790             alf12=0.5D0*(alf1+alf2)
 791 C For diagnostics only!!!
 792 c           chi1=0.0D0
 793 c           chi2=0.0D0
 794 c           chi12=0.0D0
 795 c           chip1=0.0D0
 796 c           chip2=0.0D0
 797 c           chip12=0.0D0
 798 c           alf1=0.0D0
 799 c           alf2=0.0D0
 800 c           alf12=0.0D0
 801             xj=c(1,nres+j)-xi
 802             yj=c(2,nres+j)-yi
 803             zj=c(3,nres+j)-zi
 804             dxj=dc_norm(1,nres+j)
 805             dyj=dc_norm(2,nres+j)
 806             dzj=dc_norm(3,nres+j)
 807             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 808 cd          if (icall.eq.0) then
 809 cd            rrsave(ind)=rrij
 810 cd          else
 811 cd            rrij=rrsave(ind)
 812 cd          endif
 813             rij=dsqrt(rrij)
 814 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 815             call sc_angular
 816 C Calculate whole angle-dependent part of epsilon and contributions
 817 C to its derivatives
 818             fac=(rrij*sigsq)**expon2
 819             e1=fac*fac*aa
 820             e2=fac*bb
 821             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 822             eps2der=evdwij*eps3rt
 823             eps3der=evdwij*eps2rt
 824             evdwij=evdwij*eps2rt*eps3rt
 825             ij=icant(itypi,itypj)
 826             aux=eps1*eps2rt**2*eps3rt**2
 827             if (bb.gt.0.0d0) then
 828               evdw=evdw+evdwij
 829             else
 830               evdw_t=evdw_t+evdwij
 831             endif
 832             if (calc_grad) then
 833             if (lprn) then
 834             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 835             epsi=bb**2/aa
 836 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 837 cd     &        restyp(itypi),i,restyp(itypj),j,
 838 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 839 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 840 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 841 cd     &        evdwij
 842             endif
 843 C Calculate gradient components.
 844             e1=e1*eps1*eps2rt**2*eps3rt**2
 845             fac=-expon*(e1+evdwij)
 846             sigder=fac/sigsq
 847             fac=rrij*fac
 848 C Calculate radial part of the gradient
 849             gg(1)=xj*fac
 850             gg(2)=yj*fac
 851             gg(3)=zj*fac
 852 C Calculate the angular part of the gradient and sum add the contributions
 853 C to the appropriate components of the Cartesian gradient.
 854             call sc_grad
 855             endif
 856           enddo      ! j
 857         enddo        ! iint
 858       enddo          ! i
 859 c     stop
 860       return
 861       end
 862 C-----------------------------------------------------------------------------
 863       subroutine egb(evdw,evdw_t)
 864 C
 865 C This subroutine calculates the interaction energy of nonbonded side chains
 866 C assuming the Gay-Berne potential of interaction.
 867 C
 868       implicit real*8 (a-h,o-z)
 869       include 'DIMENSIONS'
 870       include 'sizesclu.dat'
 871       include "DIMENSIONS.COMPAR"
 872       include 'COMMON.GEO'
 873       include 'COMMON.VAR'
 874       include 'COMMON.LOCAL'
 875       include 'COMMON.CHAIN'
 876       include 'COMMON.DERIV'
 877       include 'COMMON.NAMES'
 878       include 'COMMON.INTERACT'
 879       include 'COMMON.IOUNITS'
 880       include 'COMMON.CALC'
 881       include 'COMMON.SBRIDGE'
 882       logical lprn
 883       common /srutu/icall
 884       integer icant
 885       external icant
 886       integer xshift,yshift,zshift
 887       logical energy_dec /.false./
 888 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 889       evdw=0.0D0
 890       evdw_t=0.0d0
 891       lprn=.false.
 892 c      if (icall.gt.0) lprn=.true.
 893       ind=0
 894       do i=iatsc_s,iatsc_e
 895         itypi=iabs(itype(i))
 896         if (itypi.eq.ntyp1) cycle
 897         itypi1=iabs(itype(i+1))
 898         xi=c(1,nres+i)
 899         yi=c(2,nres+i)
 900         zi=c(3,nres+i)
 901           xi=mod(xi,boxxsize)
 902           if (xi.lt.0) xi=xi+boxxsize
 903           yi=mod(yi,boxysize)
 904           if (yi.lt.0) yi=yi+boxysize
 905           zi=mod(zi,boxzsize)
 906           if (zi.lt.0) zi=zi+boxzsize
 907        if ((zi.gt.bordlipbot)
 908      &.and.(zi.lt.bordliptop)) then
 909 C the energy transfer exist
 910         if (zi.lt.buflipbot) then
 911 C what fraction I am in
 912          fracinbuf=1.0d0-
 913      &        ((zi-bordlipbot)/lipbufthick)
 914 C lipbufthick is thickenes of lipid buffore
 915          sslipi=sscalelip(fracinbuf)
 916          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 917         elseif (zi.gt.bufliptop) then
 918          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 919          sslipi=sscalelip(fracinbuf)
 920          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 921         else
 922          sslipi=1.0d0
 923          ssgradlipi=0.0
 924         endif
 925        else
 926          sslipi=0.0d0
 927          ssgradlipi=0.0
 928        endif
 929         dxi=dc_norm(1,nres+i)
 930         dyi=dc_norm(2,nres+i)
 931         dzi=dc_norm(3,nres+i)
 932         dsci_inv=vbld_inv(i+nres)
 933 C
 934 C Calculate SC interaction energy.
 935 C
 936         do iint=1,nint_gr(i)
 937           do j=istart(i,iint),iend(i,iint)
 938             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 939
 940 c              write(iout,*) "PRZED ZWYKLE", evdwij
 941               call dyn_ssbond_ene(i,j,evdwij)
 942 c              write(iout,*) "PO ZWYKLE", evdwij
 943
 944               evdw=evdw+evdwij
 945               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 946      &                        'evdw',i,j,evdwij,' ss'
 947 C triple bond artifac removal
 948              do k=j+1,iend(i,iint)
 949 C search over all next residues
 950               if (dyn_ss_mask(k)) then
 951 C check if they are cysteins
 952 C              write(iout,*) 'k=',k
 953
 954 c              write(iout,*) "PRZED TRI", evdwij
 955                evdwij_przed_tri=evdwij
 956               call triple_ssbond_ene(i,j,k,evdwij)
 957 c               if(evdwij_przed_tri.ne.evdwij) then
 958 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 959 c               endif
 960
 961 c              write(iout,*) "PO TRI", evdwij
 962 C call the energy function that removes the artifical triple disulfide
 963 C bond the soubroutine is located in ssMD.F
 964               evdw=evdw+evdwij
 965               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 966      &                        'evdw',i,j,evdwij,'tss'
 967               endif!dyn_ss_mask(k)
 968              enddo! k
 969             ELSE
 970             ind=ind+1
 971             itypj=iabs(itype(j))
 972             if (itypj.eq.ntyp1) cycle
 973             dscj_inv=vbld_inv(j+nres)
 974             sig0ij=sigma(itypi,itypj)
 975             chi1=chi(itypi,itypj)
 976             chi2=chi(itypj,itypi)
 977             chi12=chi1*chi2
 978             chip1=chip(itypi)
 979             chip2=chip(itypj)
 980             chip12=chip1*chip2
 981             alf1=alp(itypi)
 982             alf2=alp(itypj)
 983             alf12=0.5D0*(alf1+alf2)
 984 C For diagnostics only!!!
 985 c           chi1=0.0D0
 986 c           chi2=0.0D0
 987 c           chi12=0.0D0
 988 c           chip1=0.0D0
 989 c           chip2=0.0D0
 990 c           chip12=0.0D0
 991 c           alf1=0.0D0
 992 c           alf2=0.0D0
 993 c           alf12=0.0D0
 994             xj=c(1,nres+j)
 995             yj=c(2,nres+j)
 996             zj=c(3,nres+j)
 997           xj=mod(xj,boxxsize)
 998           if (xj.lt.0) xj=xj+boxxsize
 999           yj=mod(yj,boxysize)
1000           if (yj.lt.0) yj=yj+boxysize
1001           zj=mod(zj,boxzsize)
1002           if (zj.lt.0) zj=zj+boxzsize
1003        if ((zj.gt.bordlipbot)
1004      &.and.(zj.lt.bordliptop)) then
1005 C the energy transfer exist
1006         if (zj.lt.buflipbot) then
1007 C what fraction I am in
1008          fracinbuf=1.0d0-
1009      &        ((zj-bordlipbot)/lipbufthick)
1010 C lipbufthick is thickenes of lipid buffore
1011          sslipj=sscalelip(fracinbuf)
1012          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1013         elseif (zj.gt.bufliptop) then
1014          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1015          sslipj=sscalelip(fracinbuf)
1016          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1017         else
1018          sslipj=1.0d0
1019          ssgradlipj=0.0
1020         endif
1021        else
1022          sslipj=0.0d0
1023          ssgradlipj=0.0
1024        endif
1025       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1026      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1027       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1028      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1029       write(iout,*) "czy jest 0", aa-aa_lip(itypi,itypj),
1030      & aa-aa_aq(itypi,itypj)
1031       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1032       xj_safe=xj
1033       yj_safe=yj
1034       zj_safe=zj
1035       subchap=0
1036       do xshift=-1,1
1037       do yshift=-1,1
1038       do zshift=-1,1
1039           xj=xj_safe+xshift*boxxsize
1040           yj=yj_safe+yshift*boxysize
1041           zj=zj_safe+zshift*boxzsize
1042           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1043           if(dist_temp.lt.dist_init) then
1044             dist_init=dist_temp
1045             xj_temp=xj
1046             yj_temp=yj
1047             zj_temp=zj
1048             subchap=1
1049           endif
1050        enddo
1051        enddo
1052        enddo
1053        if (subchap.eq.1) then
1054           xj=xj_temp-xi
1055           yj=yj_temp-yi
1056           zj=zj_temp-zi
1057        else
1058           xj=xj_safe-xi
1059           yj=yj_safe-yi
1060           zj=zj_safe-zi
1061        endif
1062             dxj=dc_norm(1,nres+j)
1063             dyj=dc_norm(2,nres+j)
1064             dzj=dc_norm(3,nres+j)
1065 c            write (iout,*) i,j,xj,yj,zj
1066             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1067             rij=dsqrt(rrij)
1068             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1069             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1070             if (sss.le.0.0d0) cycle
1071 C Calculate angle-dependent terms of energy and contributions to their
1072 C derivatives.
1073             call sc_angular
1074             sigsq=1.0D0/sigsq
1075             sig=sig0ij*dsqrt(sigsq)
1076             rij_shift=1.0D0/rij-sig+sig0ij
1077 C I hate to put IF's in the loops, but here don't have another choice!!!!
1078             if (rij_shift.le.0.0D0) then
1079               evdw=1.0D20
1080               return
1081             endif
1082             sigder=-sig*sigsq
1083 c---------------------------------------------------------------
1084             rij_shift=1.0D0/rij_shift
1085             fac=rij_shift**expon
1086             e1=fac*fac*aa
1087             e2=fac*bb
1088             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1089             eps2der=evdwij*eps3rt
1090             eps3der=evdwij*eps2rt
1091             evdwij=evdwij*eps2rt*eps3rt
1092             if (bb.gt.0) then
1093               evdw=evdw+evdwij*sss
1094             else
1095               evdw_t=evdw_t+evdwij*sss
1096             endif
1097             ij=icant(itypi,itypj)
1098             aux=eps1*eps2rt**2*eps3rt**2
1099 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1100 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1101 c     &         aux*e2/eps(itypi,itypj)
1102 c            if (lprn) then
1103             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1104             epsi=bb**2/aa
1105 C#define DEBUG
1106 #ifdef DEBUG
1107             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1108      &        restyp(itypi),i,restyp(itypj),j,
1109      &        epsi,sigm,chi1,chi2,chip1,chip2,
1110      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1111      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1112      &        evdwij
1113              write (iout,*) "pratial sum", evdw,evdw_t
1114 #endif
1115 C#undef DEBUG
1116 c            endif
1117             if (calc_grad) then
1118 C Calculate gradient components.
1119             e1=e1*eps1*eps2rt**2*eps3rt**2
1120             fac=-expon*(e1+evdwij)*rij_shift
1121             sigder=fac*sigder
1122             fac=rij*fac
1123             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1124             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1125      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1126      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1127      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1128             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1129             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1130 C Calculate the radial part of the gradient
1131             gg(1)=xj*fac
1132             gg(2)=yj*fac
1133             gg(3)=zj*fac
1134 C Calculate angular part of the gradient.
1135             call sc_grad
1136             endif
1137             ENDIF    ! dyn_ss
1138           enddo      ! j
1139         enddo        ! iint
1140       enddo          ! i
1141       return
1142       end
1143 C-----------------------------------------------------------------------------
1144       subroutine egbv(evdw,evdw_t)
1145 C
1146 C This subroutine calculates the interaction energy of nonbonded side chains
1147 C assuming the Gay-Berne-Vorobjev potential of interaction.
1148 C
1149       implicit real*8 (a-h,o-z)
1150       include 'DIMENSIONS'
1151       include 'sizesclu.dat'
1152       include "DIMENSIONS.COMPAR"
1153       include 'COMMON.GEO'
1154       include 'COMMON.VAR'
1155       include 'COMMON.LOCAL'
1156       include 'COMMON.CHAIN'
1157       include 'COMMON.DERIV'
1158       include 'COMMON.NAMES'
1159       include 'COMMON.INTERACT'
1160       include 'COMMON.IOUNITS'
1161       include 'COMMON.CALC'
1162       common /srutu/ icall
1163       logical lprn
1164       integer icant
1165       external icant
1166       evdw=0.0D0
1167       evdw_t=0.0d0
1168 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1169       evdw=0.0D0
1170       lprn=.false.
1171 c      if (icall.gt.0) lprn=.true.
1172       ind=0
1173       do i=iatsc_s,iatsc_e
1174         itypi=iabs(itype(i))
1175         if (itypi.eq.ntyp1) cycle
1176         itypi1=iabs(itype(i+1))
1177         xi=c(1,nres+i)
1178         yi=c(2,nres+i)
1179         zi=c(3,nres+i)
1180         dxi=dc_norm(1,nres+i)
1181         dyi=dc_norm(2,nres+i)
1182         dzi=dc_norm(3,nres+i)
1183         dsci_inv=vbld_inv(i+nres)
1184 C returning the ith atom to box
1185           xi=mod(xi,boxxsize)
1186           if (xi.lt.0) xi=xi+boxxsize
1187           yi=mod(yi,boxysize)
1188           if (yi.lt.0) yi=yi+boxysize
1189           zi=mod(zi,boxzsize)
1190           if (zi.lt.0) zi=zi+boxzsize
1191        if ((zi.gt.bordlipbot)
1192      &.and.(zi.lt.bordliptop)) then
1193 C the energy transfer exist
1194         if (zi.lt.buflipbot) then
1195 C what fraction I am in
1196          fracinbuf=1.0d0-
1197      &        ((zi-bordlipbot)/lipbufthick)
1198 C lipbufthick is thickenes of lipid buffore
1199          sslipi=sscalelip(fracinbuf)
1200          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1201         elseif (zi.gt.bufliptop) then
1202          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1203          sslipi=sscalelip(fracinbuf)
1204          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1205         else
1206          sslipi=1.0d0
1207          ssgradlipi=0.0
1208         endif
1209        else
1210          sslipi=0.0d0
1211          ssgradlipi=0.0
1212        endif
1213 C
1214 C Calculate SC interaction energy.
1215 C
1216         do iint=1,nint_gr(i)
1217           do j=istart(i,iint),iend(i,iint)
1218             ind=ind+1
1219             itypj=iabs(itype(j))
1220             if (itypj.eq.ntyp1) cycle
1221             dscj_inv=vbld_inv(j+nres)
1222             sig0ij=sigma(itypi,itypj)
1223             r0ij=r0(itypi,itypj)
1224             chi1=chi(itypi,itypj)
1225             chi2=chi(itypj,itypi)
1226             chi12=chi1*chi2
1227             chip1=chip(itypi)
1228             chip2=chip(itypj)
1229             chip12=chip1*chip2
1230             alf1=alp(itypi)
1231             alf2=alp(itypj)
1232             alf12=0.5D0*(alf1+alf2)
1233 C For diagnostics only!!!
1234 c           chi1=0.0D0
1235 c           chi2=0.0D0
1236 c           chi12=0.0D0
1237 c           chip1=0.0D0
1238 c           chip2=0.0D0
1239 c           chip12=0.0D0
1240 c           alf1=0.0D0
1241 c           alf2=0.0D0
1242 c           alf12=0.0D0
1243             xj=c(1,nres+j)
1244             yj=c(2,nres+j)
1245             zj=c(3,nres+j)
1246 C returning jth atom to box
1247           xj=mod(xj,boxxsize)
1248           if (xj.lt.0) xj=xj+boxxsize
1249           yj=mod(yj,boxysize)
1250           if (yj.lt.0) yj=yj+boxysize
1251           zj=mod(zj,boxzsize)
1252           if (zj.lt.0) zj=zj+boxzsize
1253        if ((zj.gt.bordlipbot)
1254      &.and.(zj.lt.bordliptop)) then
1255 C the energy transfer exist
1256         if (zj.lt.buflipbot) then
1257 C what fraction I am in
1258          fracinbuf=1.0d0-
1259      &        ((zj-bordlipbot)/lipbufthick)
1260 C lipbufthick is thickenes of lipid buffore
1261          sslipj=sscalelip(fracinbuf)
1262          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1263         elseif (zj.gt.bufliptop) then
1264          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1265          sslipj=sscalelip(fracinbuf)
1266          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1267         else
1268          sslipj=1.0d0
1269          ssgradlipj=0.0
1270         endif
1271        else
1272          sslipj=0.0d0
1273          ssgradlipj=0.0
1274        endif
1275       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1276      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1277       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1278      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1279 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1280 C checking the distance
1281       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1282       xj_safe=xj
1283       yj_safe=yj
1284       zj_safe=zj
1285       subchap=0
1286 C finding the closest
1287       do xshift=-1,1
1288       do yshift=-1,1
1289       do zshift=-1,1
1290           xj=xj_safe+xshift*boxxsize
1291           yj=yj_safe+yshift*boxysize
1292           zj=zj_safe+zshift*boxzsize
1293           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1294           if(dist_temp.lt.dist_init) then
1295             dist_init=dist_temp
1296             xj_temp=xj
1297             yj_temp=yj
1298             zj_temp=zj
1299             subchap=1
1300           endif
1301        enddo
1302        enddo
1303        enddo
1304        if (subchap.eq.1) then
1305           xj=xj_temp-xi
1306           yj=yj_temp-yi
1307           zj=zj_temp-zi
1308        else
1309           xj=xj_safe-xi
1310           yj=yj_safe-yi
1311           zj=zj_safe-zi
1312        endif
1313             dxj=dc_norm(1,nres+j)
1314             dyj=dc_norm(2,nres+j)
1315             dzj=dc_norm(3,nres+j)
1316             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1317             rij=dsqrt(rrij)
1318 C Calculate angle-dependent terms of energy and contributions to their
1319 C derivatives.
1320             call sc_angular
1321             sigsq=1.0D0/sigsq
1322             sig=sig0ij*dsqrt(sigsq)
1323             rij_shift=1.0D0/rij-sig+r0ij
1324 C I hate to put IF's in the loops, but here don't have another choice!!!!
1325             if (rij_shift.le.0.0D0) then
1326               evdw=1.0D20
1327               return
1328             endif
1329             sigder=-sig*sigsq
1330 c---------------------------------------------------------------
1331             rij_shift=1.0D0/rij_shift
1332             fac=rij_shift**expon
1333             e1=fac*fac*aa
1334             e2=fac*bb
1335             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1336             eps2der=evdwij*eps3rt
1337             eps3der=evdwij*eps2rt
1338             fac_augm=rrij**expon
1339             e_augm=augm(itypi,itypj)*fac_augm
1340             evdwij=evdwij*eps2rt*eps3rt
1341             if (bb.gt.0.0d0) then
1342               evdw=evdw+evdwij+e_augm
1343             else
1344               evdw_t=evdw_t+evdwij+e_augm
1345             endif
1346             ij=icant(itypi,itypj)
1347             aux=eps1*eps2rt**2*eps3rt**2
1348 c            if (lprn) then
1349 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1350 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1351 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1352 c     &        restyp(itypi),i,restyp(itypj),j,
1353 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1354 c     &        chi1,chi2,chip1,chip2,
1355 c     &        eps1,eps2rt**2,eps3rt**2,
1356 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1357 c     &        evdwij+e_augm
1358 c            endif
1359             if (calc_grad) then
1360 C Calculate gradient components.
1361             e1=e1*eps1*eps2rt**2*eps3rt**2
1362             fac=-expon*(e1+evdwij)*rij_shift
1363             sigder=fac*sigder
1364             fac=rij*fac-2*expon*rrij*e_augm
1365 C Calculate the radial part of the gradient
1366             gg(1)=xj*fac
1367             gg(2)=yj*fac
1368             gg(3)=zj*fac
1369 C Calculate angular part of the gradient.
1370             call sc_grad
1371             endif
1372           enddo      ! j
1373         enddo        ! iint
1374       enddo          ! i
1375       return
1376       end
1377 C-----------------------------------------------------------------------------
1378       subroutine sc_angular
1379 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1380 C om12. Called by ebp, egb, and egbv.
1381       implicit none
1382       include 'COMMON.CALC'
1383       erij(1)=xj*rij
1384       erij(2)=yj*rij
1385       erij(3)=zj*rij
1386       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1387       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1388       om12=dxi*dxj+dyi*dyj+dzi*dzj
1389       chiom12=chi12*om12
1390 C Calculate eps1(om12) and its derivative in om12
1391       faceps1=1.0D0-om12*chiom12
1392       faceps1_inv=1.0D0/faceps1
1393       eps1=dsqrt(faceps1_inv)
1394 C Following variable is eps1*deps1/dom12
1395       eps1_om12=faceps1_inv*chiom12
1396 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1397 C and om12.
1398       om1om2=om1*om2
1399       chiom1=chi1*om1
1400       chiom2=chi2*om2
1401       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1402       sigsq=1.0D0-facsig*faceps1_inv
1403       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1404       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1405       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1406 C Calculate eps2 and its derivatives in om1, om2, and om12.
1407       chipom1=chip1*om1
1408       chipom2=chip2*om2
1409       chipom12=chip12*om12
1410       facp=1.0D0-om12*chipom12
1411       facp_inv=1.0D0/facp
1412       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1413 C Following variable is the square root of eps2
1414       eps2rt=1.0D0-facp1*facp_inv
1415 C Following three variables are the derivatives of the square root of eps
1416 C in om1, om2, and om12.
1417       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1418       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1419       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1420 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1421       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1422 C Calculate whole angle-dependent part of epsilon and contributions
1423 C to its derivatives
1424       return
1425       end
1426 C----------------------------------------------------------------------------
1427       subroutine sc_grad
1428       implicit real*8 (a-h,o-z)
1429       include 'DIMENSIONS'
1430       include 'sizesclu.dat'
1431       include 'COMMON.CHAIN'
1432       include 'COMMON.DERIV'
1433       include 'COMMON.CALC'
1434       double precision dcosom1(3),dcosom2(3)
1435       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1436       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1437       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1438      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1439       do k=1,3
1440         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1441         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1442       enddo
1443       do k=1,3
1444         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1445       enddo
1446       do k=1,3
1447         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1448      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1449      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1450         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1451      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1452      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1453       enddo
1454 C
1455 C Calculate the components of the gradient in DC and X
1456 C
1457       do k=i,j-1
1458         do l=1,3
1459           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1460         enddo
1461       enddo
1462       do l=1,3
1463          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1464       enddo
1465       return
1466       end
1467 c------------------------------------------------------------------------------
1468       subroutine vec_and_deriv
1469       implicit real*8 (a-h,o-z)
1470       include 'DIMENSIONS'
1471       include 'sizesclu.dat'
1472       include 'COMMON.IOUNITS'
1473       include 'COMMON.GEO'
1474       include 'COMMON.VAR'
1475       include 'COMMON.LOCAL'
1476       include 'COMMON.CHAIN'
1477       include 'COMMON.VECTORS'
1478       include 'COMMON.DERIV'
1479       include 'COMMON.INTERACT'
1480       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1481 C Compute the local reference systems. For reference system (i), the
1482 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1483 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1484       do i=1,nres-1
1485 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1486           if (i.eq.nres-1) then
1487 C Case of the last full residue
1488 C Compute the Z-axis
1489             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1490             costh=dcos(pi-theta(nres))
1491             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1492             do k=1,3
1493               uz(k,i)=fac*uz(k,i)
1494             enddo
1495             if (calc_grad) then
1496 C Compute the derivatives of uz
1497             uzder(1,1,1)= 0.0d0
1498             uzder(2,1,1)=-dc_norm(3,i-1)
1499             uzder(3,1,1)= dc_norm(2,i-1)
1500             uzder(1,2,1)= dc_norm(3,i-1)
1501             uzder(2,2,1)= 0.0d0
1502             uzder(3,2,1)=-dc_norm(1,i-1)
1503             uzder(1,3,1)=-dc_norm(2,i-1)
1504             uzder(2,3,1)= dc_norm(1,i-1)
1505             uzder(3,3,1)= 0.0d0
1506             uzder(1,1,2)= 0.0d0
1507             uzder(2,1,2)= dc_norm(3,i)
1508             uzder(3,1,2)=-dc_norm(2,i)
1509             uzder(1,2,2)=-dc_norm(3,i)
1510             uzder(2,2,2)= 0.0d0
1511             uzder(3,2,2)= dc_norm(1,i)
1512             uzder(1,3,2)= dc_norm(2,i)
1513             uzder(2,3,2)=-dc_norm(1,i)
1514             uzder(3,3,2)= 0.0d0
1515             endif
1516 C Compute the Y-axis
1517             facy=fac
1518             do k=1,3
1519               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1520             enddo
1521             if (calc_grad) then
1522 C Compute the derivatives of uy
1523             do j=1,3
1524               do k=1,3
1525                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1526      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1527                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1528               enddo
1529               uyder(j,j,1)=uyder(j,j,1)-costh
1530               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1531             enddo
1532             do j=1,2
1533               do k=1,3
1534                 do l=1,3
1535                   uygrad(l,k,j,i)=uyder(l,k,j)
1536                   uzgrad(l,k,j,i)=uzder(l,k,j)
1537                 enddo
1538               enddo
1539             enddo
1540             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1541             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1542             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1543             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1544             endif
1545           else
1546 C Other residues
1547 C Compute the Z-axis
1548             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1549             costh=dcos(pi-theta(i+2))
1550             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1551             do k=1,3
1552               uz(k,i)=fac*uz(k,i)
1553             enddo
1554             if (calc_grad) then
1555 C Compute the derivatives of uz
1556             uzder(1,1,1)= 0.0d0
1557             uzder(2,1,1)=-dc_norm(3,i+1)
1558             uzder(3,1,1)= dc_norm(2,i+1)
1559             uzder(1,2,1)= dc_norm(3,i+1)
1560             uzder(2,2,1)= 0.0d0
1561             uzder(3,2,1)=-dc_norm(1,i+1)
1562             uzder(1,3,1)=-dc_norm(2,i+1)
1563             uzder(2,3,1)= dc_norm(1,i+1)
1564             uzder(3,3,1)= 0.0d0
1565             uzder(1,1,2)= 0.0d0
1566             uzder(2,1,2)= dc_norm(3,i)
1567             uzder(3,1,2)=-dc_norm(2,i)
1568             uzder(1,2,2)=-dc_norm(3,i)
1569             uzder(2,2,2)= 0.0d0
1570             uzder(3,2,2)= dc_norm(1,i)
1571             uzder(1,3,2)= dc_norm(2,i)
1572             uzder(2,3,2)=-dc_norm(1,i)
1573             uzder(3,3,2)= 0.0d0
1574             endif
1575 C Compute the Y-axis
1576             facy=fac
1577             do k=1,3
1578               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1579             enddo
1580             if (calc_grad) then
1581 C Compute the derivatives of uy
1582             do j=1,3
1583               do k=1,3
1584                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1585      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1586                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1587               enddo
1588               uyder(j,j,1)=uyder(j,j,1)-costh
1589               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1590             enddo
1591             do j=1,2
1592               do k=1,3
1593                 do l=1,3
1594                   uygrad(l,k,j,i)=uyder(l,k,j)
1595                   uzgrad(l,k,j,i)=uzder(l,k,j)
1596                 enddo
1597               enddo
1598             enddo
1599             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1600             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1601             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1602             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1603           endif
1604           endif
1605       enddo
1606       if (calc_grad) then
1607       do i=1,nres-1
1608         vbld_inv_temp(1)=vbld_inv(i+1)
1609         if (i.lt.nres-1) then
1610           vbld_inv_temp(2)=vbld_inv(i+2)
1611         else
1612           vbld_inv_temp(2)=vbld_inv(i)
1613         endif
1614         do j=1,2
1615           do k=1,3
1616             do l=1,3
1617               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1618               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1619             enddo
1620           enddo
1621         enddo
1622       enddo
1623       endif
1624       return
1625       end
1626 C-----------------------------------------------------------------------------
1627       subroutine vec_and_deriv_test
1628       implicit real*8 (a-h,o-z)
1629       include 'DIMENSIONS'
1630       include 'sizesclu.dat'
1631       include 'COMMON.IOUNITS'
1632       include 'COMMON.GEO'
1633       include 'COMMON.VAR'
1634       include 'COMMON.LOCAL'
1635       include 'COMMON.CHAIN'
1636       include 'COMMON.VECTORS'
1637       dimension uyder(3,3,2),uzder(3,3,2)
1638 C Compute the local reference systems. For reference system (i), the
1639 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1640 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1641       do i=1,nres-1
1642           if (i.eq.nres-1) then
1643 C Case of the last full residue
1644 C Compute the Z-axis
1645             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1646             costh=dcos(pi-theta(nres))
1647             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1648 c            write (iout,*) 'fac',fac,
1649 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1650             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1651             do k=1,3
1652               uz(k,i)=fac*uz(k,i)
1653             enddo
1654 C Compute the derivatives of uz
1655             uzder(1,1,1)= 0.0d0
1656             uzder(2,1,1)=-dc_norm(3,i-1)
1657             uzder(3,1,1)= dc_norm(2,i-1)
1658             uzder(1,2,1)= dc_norm(3,i-1)
1659             uzder(2,2,1)= 0.0d0
1660             uzder(3,2,1)=-dc_norm(1,i-1)
1661             uzder(1,3,1)=-dc_norm(2,i-1)
1662             uzder(2,3,1)= dc_norm(1,i-1)
1663             uzder(3,3,1)= 0.0d0
1664             uzder(1,1,2)= 0.0d0
1665             uzder(2,1,2)= dc_norm(3,i)
1666             uzder(3,1,2)=-dc_norm(2,i)
1667             uzder(1,2,2)=-dc_norm(3,i)
1668             uzder(2,2,2)= 0.0d0
1669             uzder(3,2,2)= dc_norm(1,i)
1670             uzder(1,3,2)= dc_norm(2,i)
1671             uzder(2,3,2)=-dc_norm(1,i)
1672             uzder(3,3,2)= 0.0d0
1673 C Compute the Y-axis
1674             do k=1,3
1675               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1676             enddo
1677             facy=fac
1678             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1679      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1680      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1681             do k=1,3
1682 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1683               uy(k,i)=
1684 c     &        facy*(
1685      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1686      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1687 c     &        )
1688             enddo
1689 c            write (iout,*) 'facy',facy,
1690 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1691             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1692             do k=1,3
1693               uy(k,i)=facy*uy(k,i)
1694             enddo
1695 C Compute the derivatives of uy
1696             do j=1,3
1697               do k=1,3
1698                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1699      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1700                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1701               enddo
1702 c              uyder(j,j,1)=uyder(j,j,1)-costh
1703 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1704               uyder(j,j,1)=uyder(j,j,1)
1705      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1706               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1707      &          +uyder(j,j,2)
1708             enddo
1709             do j=1,2
1710               do k=1,3
1711                 do l=1,3
1712                   uygrad(l,k,j,i)=uyder(l,k,j)
1713                   uzgrad(l,k,j,i)=uzder(l,k,j)
1714                 enddo
1715               enddo
1716             enddo
1717             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1718             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1719             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1720             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1721           else
1722 C Other residues
1723 C Compute the Z-axis
1724             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1725             costh=dcos(pi-theta(i+2))
1726             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1727             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1728             do k=1,3
1729               uz(k,i)=fac*uz(k,i)
1730             enddo
1731 C Compute the derivatives of uz
1732             uzder(1,1,1)= 0.0d0
1733             uzder(2,1,1)=-dc_norm(3,i+1)
1734             uzder(3,1,1)= dc_norm(2,i+1)
1735             uzder(1,2,1)= dc_norm(3,i+1)
1736             uzder(2,2,1)= 0.0d0
1737             uzder(3,2,1)=-dc_norm(1,i+1)
1738             uzder(1,3,1)=-dc_norm(2,i+1)
1739             uzder(2,3,1)= dc_norm(1,i+1)
1740             uzder(3,3,1)= 0.0d0
1741             uzder(1,1,2)= 0.0d0
1742             uzder(2,1,2)= dc_norm(3,i)
1743             uzder(3,1,2)=-dc_norm(2,i)
1744             uzder(1,2,2)=-dc_norm(3,i)
1745             uzder(2,2,2)= 0.0d0
1746             uzder(3,2,2)= dc_norm(1,i)
1747             uzder(1,3,2)= dc_norm(2,i)
1748             uzder(2,3,2)=-dc_norm(1,i)
1749             uzder(3,3,2)= 0.0d0
1750 C Compute the Y-axis
1751             facy=fac
1752             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1753      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1754      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1755             do k=1,3
1756 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1757               uy(k,i)=
1758 c     &        facy*(
1759      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1760      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1761 c     &        )
1762             enddo
1763 c            write (iout,*) 'facy',facy,
1764 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1765             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1766             do k=1,3
1767               uy(k,i)=facy*uy(k,i)
1768             enddo
1769 C Compute the derivatives of uy
1770             do j=1,3
1771               do k=1,3
1772                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1773      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1774                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1775               enddo
1776 c              uyder(j,j,1)=uyder(j,j,1)-costh
1777 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1778               uyder(j,j,1)=uyder(j,j,1)
1779      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1780               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1781      &          +uyder(j,j,2)
1782             enddo
1783             do j=1,2
1784               do k=1,3
1785                 do l=1,3
1786                   uygrad(l,k,j,i)=uyder(l,k,j)
1787                   uzgrad(l,k,j,i)=uzder(l,k,j)
1788                 enddo
1789               enddo
1790             enddo
1791             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1792             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1793             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1794             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1795           endif
1796       enddo
1797       do i=1,nres-1
1798         do j=1,2
1799           do k=1,3
1800             do l=1,3
1801               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1802               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1803             enddo
1804           enddo
1805         enddo
1806       enddo
1807       return
1808       end
1809 C-----------------------------------------------------------------------------
1810       subroutine check_vecgrad
1811       implicit real*8 (a-h,o-z)
1812       include 'DIMENSIONS'
1813       include 'sizesclu.dat'
1814       include 'COMMON.IOUNITS'
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.VECTORS'
1820       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1821       dimension uyt(3,maxres),uzt(3,maxres)
1822       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1823       double precision delta /1.0d-7/
1824       call vec_and_deriv
1825 cd      do i=1,nres
1826 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1827 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1828 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1829 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1830 cd     &     (dc_norm(if90,i),if90=1,3)
1831 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1832 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1833 cd          write(iout,'(a)')
1834 cd      enddo
1835       do i=1,nres
1836         do j=1,2
1837           do k=1,3
1838             do l=1,3
1839               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1840               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1841             enddo
1842           enddo
1843         enddo
1844       enddo
1845       call vec_and_deriv
1846       do i=1,nres
1847         do j=1,3
1848           uyt(j,i)=uy(j,i)
1849           uzt(j,i)=uz(j,i)
1850         enddo
1851       enddo
1852       do i=1,nres
1853 cd        write (iout,*) 'i=',i
1854         do k=1,3
1855           erij(k)=dc_norm(k,i)
1856         enddo
1857         do j=1,3
1858           do k=1,3
1859             dc_norm(k,i)=erij(k)
1860           enddo
1861           dc_norm(j,i)=dc_norm(j,i)+delta
1862 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1863 c          do k=1,3
1864 c            dc_norm(k,i)=dc_norm(k,i)/fac
1865 c          enddo
1866 c          write (iout,*) (dc_norm(k,i),k=1,3)
1867 c          write (iout,*) (erij(k),k=1,3)
1868           call vec_and_deriv
1869           do k=1,3
1870             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1871             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1872             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1873             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1874           enddo
1875 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1876 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1877 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1878         enddo
1879         do k=1,3
1880           dc_norm(k,i)=erij(k)
1881         enddo
1882 cd        do k=1,3
1883 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1884 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1885 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1886 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1887 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1888 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1889 cd          write (iout,'(a)')
1890 cd        enddo
1891       enddo
1892       return
1893       end
1894 C--------------------------------------------------------------------------
1895       subroutine set_matrices
1896       implicit real*8 (a-h,o-z)
1897       include 'DIMENSIONS'
1898       include 'sizesclu.dat'
1899       include 'COMMON.IOUNITS'
1900       include 'COMMON.GEO'
1901       include 'COMMON.VAR'
1902       include 'COMMON.LOCAL'
1903       include 'COMMON.CHAIN'
1904       include 'COMMON.DERIV'
1905       include 'COMMON.INTERACT'
1906       include 'COMMON.CONTACTS'
1907       include 'COMMON.TORSION'
1908       include 'COMMON.VECTORS'
1909       include 'COMMON.FFIELD'
1910       double precision auxvec(2),auxmat(2,2)
1911 C
1912 C Compute the virtual-bond-torsional-angle dependent quantities needed
1913 C to calculate the el-loc multibody terms of various order.
1914 C
1915       do i=3,nres+1
1916         if (i .lt. nres+1) then
1917           sin1=dsin(phi(i))
1918           cos1=dcos(phi(i))
1919           sintab(i-2)=sin1
1920           costab(i-2)=cos1
1921           obrot(1,i-2)=cos1
1922           obrot(2,i-2)=sin1
1923           sin2=dsin(2*phi(i))
1924           cos2=dcos(2*phi(i))
1925           sintab2(i-2)=sin2
1926           costab2(i-2)=cos2
1927           obrot2(1,i-2)=cos2
1928           obrot2(2,i-2)=sin2
1929           Ug(1,1,i-2)=-cos1
1930           Ug(1,2,i-2)=-sin1
1931           Ug(2,1,i-2)=-sin1
1932           Ug(2,2,i-2)= cos1
1933           Ug2(1,1,i-2)=-cos2
1934           Ug2(1,2,i-2)=-sin2
1935           Ug2(2,1,i-2)=-sin2
1936           Ug2(2,2,i-2)= cos2
1937         else
1938           costab(i-2)=1.0d0
1939           sintab(i-2)=0.0d0
1940           obrot(1,i-2)=1.0d0
1941           obrot(2,i-2)=0.0d0
1942           obrot2(1,i-2)=0.0d0
1943           obrot2(2,i-2)=0.0d0
1944           Ug(1,1,i-2)=1.0d0
1945           Ug(1,2,i-2)=0.0d0
1946           Ug(2,1,i-2)=0.0d0
1947           Ug(2,2,i-2)=1.0d0
1948           Ug2(1,1,i-2)=0.0d0
1949           Ug2(1,2,i-2)=0.0d0
1950           Ug2(2,1,i-2)=0.0d0
1951           Ug2(2,2,i-2)=0.0d0
1952         endif
1953         if (i .gt. 3 .and. i .lt. nres+1) then
1954           obrot_der(1,i-2)=-sin1
1955           obrot_der(2,i-2)= cos1
1956           Ugder(1,1,i-2)= sin1
1957           Ugder(1,2,i-2)=-cos1
1958           Ugder(2,1,i-2)=-cos1
1959           Ugder(2,2,i-2)=-sin1
1960           dwacos2=cos2+cos2
1961           dwasin2=sin2+sin2
1962           obrot2_der(1,i-2)=-dwasin2
1963           obrot2_der(2,i-2)= dwacos2
1964           Ug2der(1,1,i-2)= dwasin2
1965           Ug2der(1,2,i-2)=-dwacos2
1966           Ug2der(2,1,i-2)=-dwacos2
1967           Ug2der(2,2,i-2)=-dwasin2
1968         else
1969           obrot_der(1,i-2)=0.0d0
1970           obrot_der(2,i-2)=0.0d0
1971           Ugder(1,1,i-2)=0.0d0
1972           Ugder(1,2,i-2)=0.0d0
1973           Ugder(2,1,i-2)=0.0d0
1974           Ugder(2,2,i-2)=0.0d0
1975           obrot2_der(1,i-2)=0.0d0
1976           obrot2_der(2,i-2)=0.0d0
1977           Ug2der(1,1,i-2)=0.0d0
1978           Ug2der(1,2,i-2)=0.0d0
1979           Ug2der(2,1,i-2)=0.0d0
1980           Ug2der(2,2,i-2)=0.0d0
1981         endif
1982         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1983           if (itype(i-2).le.ntyp) then
1984             iti = itortyp(itype(i-2))
1985           else
1986             iti=ntortyp+1
1987           endif
1988         else
1989           iti=ntortyp+1
1990         endif
1991         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1992           if (itype(i-1).le.ntyp) then
1993             iti1 = itortyp(itype(i-1))
1994           else
1995             iti1=ntortyp+1
1996           endif
1997         else
1998           iti1=ntortyp+1
1999         endif
2000 cd        write (iout,*) '*******i',i,' iti1',iti
2001 cd        write (iout,*) 'b1',b1(:,iti)
2002 cd        write (iout,*) 'b2',b2(:,iti)
2003 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2004 c        print *,"itilde1 i iti iti1",i,iti,iti1
2005         if (i .gt. iatel_s+2) then
2006           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2007           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2008           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2009           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2010           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2011           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2012           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2013         else
2014           do k=1,2
2015             Ub2(k,i-2)=0.0d0
2016             Ctobr(k,i-2)=0.0d0
2017             Dtobr2(k,i-2)=0.0d0
2018             do l=1,2
2019               EUg(l,k,i-2)=0.0d0
2020               CUg(l,k,i-2)=0.0d0
2021               DUg(l,k,i-2)=0.0d0
2022               DtUg2(l,k,i-2)=0.0d0
2023             enddo
2024           enddo
2025         endif
2026 c        print *,"itilde2 i iti iti1",i,iti,iti1
2027         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2028         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2029         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2030         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2031         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2032         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2033         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2034 c        print *,"itilde3 i iti iti1",i,iti,iti1
2035         do k=1,2
2036           muder(k,i-2)=Ub2der(k,i-2)
2037         enddo
2038         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2039           if (itype(i-1).le.ntyp) then
2040             iti1 = itortyp(itype(i-1))
2041           else
2042             iti1=ntortyp+1
2043           endif
2044         else
2045           iti1=ntortyp+1
2046         endif
2047         do k=1,2
2048           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2049         enddo
2050 C Vectors and matrices dependent on a single virtual-bond dihedral.
2051         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2052         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2053         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2054         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2055         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2056         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2057         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2058         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2059         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2060 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2061 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2062       enddo
2063 C Matrices dependent on two consecutive virtual-bond dihedrals.
2064 C The order of matrices is from left to right.
2065       do i=2,nres-1
2066         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2067         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2068         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2069         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2070         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2071         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2072         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2073         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2074       enddo
2075 cd      do i=1,nres
2076 cd        iti = itortyp(itype(i))
2077 cd        write (iout,*) i
2078 cd        do j=1,2
2079 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2080 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2081 cd        enddo
2082 cd      enddo
2083       return
2084       end
2085 C--------------------------------------------------------------------------
2086       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2087 C
2088 C This subroutine calculates the average interaction energy and its gradient
2089 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2090 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2091 C The potential depends both on the distance of peptide-group centers and on
2092 C the orientation of the CA-CA virtual bonds.
2093 C
2094       implicit real*8 (a-h,o-z)
2095       include 'DIMENSIONS'
2096       include 'sizesclu.dat'
2097       include 'COMMON.CONTROL'
2098       include 'COMMON.IOUNITS'
2099       include 'COMMON.GEO'
2100       include 'COMMON.VAR'
2101       include 'COMMON.LOCAL'
2102       include 'COMMON.CHAIN'
2103       include 'COMMON.DERIV'
2104       include 'COMMON.INTERACT'
2105       include 'COMMON.CONTACTS'
2106       include 'COMMON.TORSION'
2107       include 'COMMON.VECTORS'
2108       include 'COMMON.FFIELD'
2109       include 'COMMON.SHIELD'
2110
2111       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2112      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2113       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2114      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2115       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2116 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2117       double precision scal_el /0.5d0/
2118 C 12/13/98
2119 C 13-go grudnia roku pamietnego...
2120       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2121      &                   0.0d0,1.0d0,0.0d0,
2122      &                   0.0d0,0.0d0,1.0d0/
2123 cd      write(iout,*) 'In EELEC'
2124 cd      do i=1,nloctyp
2125 cd        write(iout,*) 'Type',i
2126 cd        write(iout,*) 'B1',B1(:,i)
2127 cd        write(iout,*) 'B2',B2(:,i)
2128 cd        write(iout,*) 'CC',CC(:,:,i)
2129 cd        write(iout,*) 'DD',DD(:,:,i)
2130 cd        write(iout,*) 'EE',EE(:,:,i)
2131 cd      enddo
2132 cd      call check_vecgrad
2133 cd      stop
2134       if (icheckgrad.eq.1) then
2135         do i=1,nres-1
2136           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2137           do k=1,3
2138             dc_norm(k,i)=dc(k,i)*fac
2139           enddo
2140 c          write (iout,*) 'i',i,' fac',fac
2141         enddo
2142       endif
2143       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2144      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2145      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2146 cd      if (wel_loc.gt.0.0d0) then
2147         if (icheckgrad.eq.1) then
2148         call vec_and_deriv_test
2149         else
2150         call vec_and_deriv
2151         endif
2152         call set_matrices
2153       endif
2154 cd      do i=1,nres-1
2155 cd        write (iout,*) 'i=',i
2156 cd        do k=1,3
2157 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2158 cd        enddo
2159 cd        do k=1,3
2160 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2161 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2162 cd        enddo
2163 cd      enddo
2164       num_conti_hb=0
2165       ees=0.0D0
2166       evdw1=0.0D0
2167       eel_loc=0.0d0
2168       eello_turn3=0.0d0
2169       eello_turn4=0.0d0
2170       ind=0
2171       do i=1,nres
2172         num_cont_hb(i)=0
2173       enddo
2174 cd      print '(a)','Enter EELEC'
2175 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2176       do i=1,nres
2177         gel_loc_loc(i)=0.0d0
2178         gcorr_loc(i)=0.0d0
2179       enddo
2180       do i=iatel_s,iatel_e
2181 C          if (i.eq.1) then
2182            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2183 C     &  .or. itype(i+2).eq.ntyp1) cycle
2184 C          else
2185 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2186 C     &  .or. itype(i+2).eq.ntyp1
2187 C     &  .or. itype(i-1).eq.ntyp1
2188      &) cycle
2189 C         endif
2190         if (itel(i).eq.0) goto 1215
2191         dxi=dc(1,i)
2192         dyi=dc(2,i)
2193         dzi=dc(3,i)
2194         dx_normi=dc_norm(1,i)
2195         dy_normi=dc_norm(2,i)
2196         dz_normi=dc_norm(3,i)
2197         xmedi=c(1,i)+0.5d0*dxi
2198         ymedi=c(2,i)+0.5d0*dyi
2199         zmedi=c(3,i)+0.5d0*dzi
2200           xmedi=mod(xmedi,boxxsize)
2201           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2202           ymedi=mod(ymedi,boxysize)
2203           if (ymedi.lt.0) ymedi=ymedi+boxysize
2204           zmedi=mod(zmedi,boxzsize)
2205           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2206         num_conti=0
2207 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2208         do j=ielstart(i),ielend(i)
2209           if (j.le.1) cycle
2210 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2211 C     & .or.itype(j+2).eq.ntyp1
2212 C     &) cycle
2213 C          else
2214           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2215 C     & .or.itype(j+2).eq.ntyp1
2216 C     & .or.itype(j-1).eq.ntyp1
2217      &) cycle
2218 C         endif
2219           if (itel(j).eq.0) goto 1216
2220           ind=ind+1
2221           iteli=itel(i)
2222           itelj=itel(j)
2223           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2224           aaa=app(iteli,itelj)
2225           bbb=bpp(iteli,itelj)
2226 C Diagnostics only!!!
2227 c         aaa=0.0D0
2228 c         bbb=0.0D0
2229 c         ael6i=0.0D0
2230 c         ael3i=0.0D0
2231 C End diagnostics
2232           ael6i=ael6(iteli,itelj)
2233           ael3i=ael3(iteli,itelj)
2234           dxj=dc(1,j)
2235           dyj=dc(2,j)
2236           dzj=dc(3,j)
2237           dx_normj=dc_norm(1,j)
2238           dy_normj=dc_norm(2,j)
2239           dz_normj=dc_norm(3,j)
2240           xj=c(1,j)+0.5D0*dxj
2241           yj=c(2,j)+0.5D0*dyj
2242           zj=c(3,j)+0.5D0*dzj
2243          xj=mod(xj,boxxsize)
2244           if (xj.lt.0) xj=xj+boxxsize
2245           yj=mod(yj,boxysize)
2246           if (yj.lt.0) yj=yj+boxysize
2247           zj=mod(zj,boxzsize)
2248           if (zj.lt.0) zj=zj+boxzsize
2249       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2250       xj_safe=xj
2251       yj_safe=yj
2252       zj_safe=zj
2253       isubchap=0
2254       do xshift=-1,1
2255       do yshift=-1,1
2256       do zshift=-1,1
2257           xj=xj_safe+xshift*boxxsize
2258           yj=yj_safe+yshift*boxysize
2259           zj=zj_safe+zshift*boxzsize
2260           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2261           if(dist_temp.lt.dist_init) then
2262             dist_init=dist_temp
2263             xj_temp=xj
2264             yj_temp=yj
2265             zj_temp=zj
2266             isubchap=1
2267           endif
2268        enddo
2269        enddo
2270        enddo
2271        if (isubchap.eq.1) then
2272           xj=xj_temp-xmedi
2273           yj=yj_temp-ymedi
2274           zj=zj_temp-zmedi
2275        else
2276           xj=xj_safe-xmedi
2277           yj=yj_safe-ymedi
2278           zj=zj_safe-zmedi
2279        endif
2280
2281           rij=xj*xj+yj*yj+zj*zj
2282             sss=sscale(sqrt(rij))
2283             sssgrad=sscagrad(sqrt(rij))
2284           rrmij=1.0D0/rij
2285           rij=dsqrt(rij)
2286           rmij=1.0D0/rij
2287           r3ij=rrmij*rmij
2288           r6ij=r3ij*r3ij
2289           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2290           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2291           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2292           fac=cosa-3.0D0*cosb*cosg
2293           ev1=aaa*r6ij*r6ij
2294 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2295           if (j.eq.i+2) ev1=scal_el*ev1
2296           ev2=bbb*r6ij
2297           fac3=ael6i*r6ij
2298           fac4=ael3i*r3ij
2299           evdwij=ev1+ev2
2300           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2301           el2=fac4*fac
2302           eesij=el1+el2
2303 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2304 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2305           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2306           if (shield_mode.gt.0) then
2307 C          fac_shield(i)=0.4
2308 C          fac_shield(j)=0.6
2309 C#define DEBUG
2310 #ifdef DEBUG
2311           write(iout,*) "ees_compon",i,j,el1,el2,
2312      &    fac_shield(i),fac_shield(j)
2313 #endif
2314 C#undef DEBUG
2315           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2316           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2317           eesij=(el1+el2)
2318           ees=ees+eesij
2319           else
2320           fac_shield(i)=1.0
2321           fac_shield(j)=1.0
2322           eesij=(el1+el2)
2323           ees=ees+eesij
2324           endif
2325 C          ees=ees+eesij
2326           evdw1=evdw1+evdwij*sss
2327 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2328 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2329 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2330 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2331 C
2332 C Calculate contributions to the Cartesian gradient.
2333 C
2334 #ifdef SPLITELE
2335           facvdw=-6*rrmij*(ev1+evdwij)*sss
2336           facel=-3*rrmij*(el1+eesij)
2337           fac1=fac
2338           erij(1)=xj*rmij
2339           erij(2)=yj*rmij
2340           erij(3)=zj*rmij
2341           if (calc_grad) then
2342 *
2343 * Radial derivatives. First process both termini of the fragment (i,j)
2344 *
2345           ggg(1)=facel*xj
2346           ggg(2)=facel*yj
2347           ggg(3)=facel*zj
2348
2349           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2350      &  (shield_mode.gt.0)) then
2351 C          print *,i,j
2352           do ilist=1,ishield_list(i)
2353            iresshield=shield_list(ilist,i)
2354            do k=1,3
2355            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2356      &      *2.0
2357            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2358      &              rlocshield
2359      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2360             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2361 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2362 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2363 C             if (iresshield.gt.i) then
2364 C               do ishi=i+1,iresshield-1
2365 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2366 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2367 C
2368 C              enddo
2369 C             else
2370 C               do ishi=iresshield,i
2371 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2372 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2373 C
2374 C               enddo
2375 C              endif
2376 C           enddo
2377 C          enddo
2378            enddo
2379           enddo
2380           do ilist=1,ishield_list(j)
2381            iresshield=shield_list(ilist,j)
2382            do k=1,3
2383            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2384      &     *2.0
2385            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2386      &              rlocshield
2387      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2388            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2389            enddo
2390           enddo
2391
2392           do k=1,3
2393             gshieldc(k,i)=gshieldc(k,i)+
2394      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2395             gshieldc(k,j)=gshieldc(k,j)+
2396      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2397             gshieldc(k,i-1)=gshieldc(k,i-1)+
2398      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2399             gshieldc(k,j-1)=gshieldc(k,j-1)+
2400      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2401
2402            enddo
2403            endif
2404
2405           do k=1,3
2406             ghalf=0.5D0*ggg(k)
2407             gelc(k,i)=gelc(k,i)+ghalf
2408             gelc(k,j)=gelc(k,j)+ghalf
2409           enddo
2410 *
2411 * Loop over residues i+1 thru j-1.
2412 *
2413           do k=i+1,j-1
2414             do l=1,3
2415               gelc(l,k)=gelc(l,k)+ggg(l)
2416             enddo
2417           enddo
2418 C          ggg(1)=facvdw*xj
2419 C          ggg(2)=facvdw*yj
2420 C          ggg(3)=facvdw*zj
2421           if (sss.gt.0.0) then
2422           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2423           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2424           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2425           else
2426           ggg(1)=0.0
2427           ggg(2)=0.0
2428           ggg(3)=0.0
2429           endif
2430           do k=1,3
2431             ghalf=0.5D0*ggg(k)
2432             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2433             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2434           enddo
2435 *
2436 * Loop over residues i+1 thru j-1.
2437 *
2438           do k=i+1,j-1
2439             do l=1,3
2440               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2441             enddo
2442           enddo
2443 #else
2444           facvdw=(ev1+evdwij)*sss
2445           facel=el1+eesij
2446           fac1=fac
2447           fac=-3*rrmij*(facvdw+facvdw+facel)
2448           erij(1)=xj*rmij
2449           erij(2)=yj*rmij
2450           erij(3)=zj*rmij
2451           if (calc_grad) then
2452 *
2453 * Radial derivatives. First process both termini of the fragment (i,j)
2454 *
2455           ggg(1)=fac*xj
2456           ggg(2)=fac*yj
2457           ggg(3)=fac*zj
2458           do k=1,3
2459             ghalf=0.5D0*ggg(k)
2460             gelc(k,i)=gelc(k,i)+ghalf
2461             gelc(k,j)=gelc(k,j)+ghalf
2462           enddo
2463 *
2464 * Loop over residues i+1 thru j-1.
2465 *
2466           do k=i+1,j-1
2467             do l=1,3
2468               gelc(l,k)=gelc(l,k)+ggg(l)
2469             enddo
2470           enddo
2471 #endif
2472 *
2473 * Angular part
2474 *
2475           ecosa=2.0D0*fac3*fac1+fac4
2476           fac4=-3.0D0*fac4
2477           fac3=-6.0D0*fac3
2478           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2479           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2480           do k=1,3
2481             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2482             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2483           enddo
2484 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2485 cd   &          (dcosg(k),k=1,3)
2486           do k=1,3
2487             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2488      &      *fac_shield(i)**2*fac_shield(j)**2
2489           enddo
2490           do k=1,3
2491             ghalf=0.5D0*ggg(k)
2492             gelc(k,i)=gelc(k,i)+ghalf
2493      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2494      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2495      &           *fac_shield(i)**2*fac_shield(j)**2
2496
2497             gelc(k,j)=gelc(k,j)+ghalf
2498      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2499      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2500      &           *fac_shield(i)**2*fac_shield(j)**2
2501           enddo
2502           do k=i+1,j-1
2503             do l=1,3
2504               gelc(l,k)=gelc(l,k)+ggg(l)
2505             enddo
2506           enddo
2507           endif
2508
2509           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2510      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2511      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2512 C
2513 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2514 C   energy of a peptide unit is assumed in the form of a second-order
2515 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2516 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2517 C   are computed for EVERY pair of non-contiguous peptide groups.
2518 C
2519           if (j.lt.nres-1) then
2520             j1=j+1
2521             j2=j-1
2522           else
2523             j1=j-1
2524             j2=j-2
2525           endif
2526           kkk=0
2527           do k=1,2
2528             do l=1,2
2529               kkk=kkk+1
2530               muij(kkk)=mu(k,i)*mu(l,j)
2531             enddo
2532           enddo
2533 cd         write (iout,*) 'EELEC: i',i,' j',j
2534 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2535 cd          write(iout,*) 'muij',muij
2536           ury=scalar(uy(1,i),erij)
2537           urz=scalar(uz(1,i),erij)
2538           vry=scalar(uy(1,j),erij)
2539           vrz=scalar(uz(1,j),erij)
2540           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2541           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2542           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2543           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2544 C For diagnostics only
2545 cd          a22=1.0d0
2546 cd          a23=1.0d0
2547 cd          a32=1.0d0
2548 cd          a33=1.0d0
2549           fac=dsqrt(-ael6i)*r3ij
2550 cd          write (2,*) 'fac=',fac
2551 C For diagnostics only
2552 cd          fac=1.0d0
2553           a22=a22*fac
2554           a23=a23*fac
2555           a32=a32*fac
2556           a33=a33*fac
2557 cd          write (iout,'(4i5,4f10.5)')
2558 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2559 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2560 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2561 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2562 cd          write (iout,'(4f10.5)')
2563 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2564 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2565 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2566 cd           write (iout,'(2i3,9f10.5/)') i,j,
2567 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2568           if (calc_grad) then
2569 C Derivatives of the elements of A in virtual-bond vectors
2570           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2571 cd          do k=1,3
2572 cd            do l=1,3
2573 cd              erder(k,l)=0.0d0
2574 cd            enddo
2575 cd          enddo
2576           do k=1,3
2577             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2578             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2579             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2580             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2581             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2582             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2583             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2584             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2585             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2586             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2587             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2588             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2589           enddo
2590 cd          do k=1,3
2591 cd            do l=1,3
2592 cd              uryg(k,l)=0.0d0
2593 cd              urzg(k,l)=0.0d0
2594 cd              vryg(k,l)=0.0d0
2595 cd              vrzg(k,l)=0.0d0
2596 cd            enddo
2597 cd          enddo
2598 C Compute radial contributions to the gradient
2599           facr=-3.0d0*rrmij
2600           a22der=a22*facr
2601           a23der=a23*facr
2602           a32der=a32*facr
2603           a33der=a33*facr
2604 cd          a22der=0.0d0
2605 cd          a23der=0.0d0
2606 cd          a32der=0.0d0
2607 cd          a33der=0.0d0
2608           agg(1,1)=a22der*xj
2609           agg(2,1)=a22der*yj
2610           agg(3,1)=a22der*zj
2611           agg(1,2)=a23der*xj
2612           agg(2,2)=a23der*yj
2613           agg(3,2)=a23der*zj
2614           agg(1,3)=a32der*xj
2615           agg(2,3)=a32der*yj
2616           agg(3,3)=a32der*zj
2617           agg(1,4)=a33der*xj
2618           agg(2,4)=a33der*yj
2619           agg(3,4)=a33der*zj
2620 C Add the contributions coming from er
2621           fac3=-3.0d0*fac
2622           do k=1,3
2623             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2624             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2625             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2626             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2627           enddo
2628           do k=1,3
2629 C Derivatives in DC(i)
2630             ghalf1=0.5d0*agg(k,1)
2631             ghalf2=0.5d0*agg(k,2)
2632             ghalf3=0.5d0*agg(k,3)
2633             ghalf4=0.5d0*agg(k,4)
2634             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2635      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2636             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2637      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2638             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2639      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2640             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2641      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2642 C Derivatives in DC(i+1)
2643             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2644      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2645             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2646      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2647             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2648      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2649             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2650      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2651 C Derivatives in DC(j)
2652             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2653      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2654             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2655      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2656             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2657      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2658             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2659      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2660 C Derivatives in DC(j+1) or DC(nres-1)
2661             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2662      &      -3.0d0*vryg(k,3)*ury)
2663             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2664      &      -3.0d0*vrzg(k,3)*ury)
2665             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2666      &      -3.0d0*vryg(k,3)*urz)
2667             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2668      &      -3.0d0*vrzg(k,3)*urz)
2669 cd            aggi(k,1)=ghalf1
2670 cd            aggi(k,2)=ghalf2
2671 cd            aggi(k,3)=ghalf3
2672 cd            aggi(k,4)=ghalf4
2673 C Derivatives in DC(i+1)
2674 cd            aggi1(k,1)=agg(k,1)
2675 cd            aggi1(k,2)=agg(k,2)
2676 cd            aggi1(k,3)=agg(k,3)
2677 cd            aggi1(k,4)=agg(k,4)
2678 C Derivatives in DC(j)
2679 cd            aggj(k,1)=ghalf1
2680 cd            aggj(k,2)=ghalf2
2681 cd            aggj(k,3)=ghalf3
2682 cd            aggj(k,4)=ghalf4
2683 C Derivatives in DC(j+1)
2684 cd            aggj1(k,1)=0.0d0
2685 cd            aggj1(k,2)=0.0d0
2686 cd            aggj1(k,3)=0.0d0
2687 cd            aggj1(k,4)=0.0d0
2688             if (j.eq.nres-1 .and. i.lt.j-2) then
2689               do l=1,4
2690                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2691 cd                aggj1(k,l)=agg(k,l)
2692               enddo
2693             endif
2694           enddo
2695           endif
2696 c          goto 11111
2697 C Check the loc-el terms by numerical integration
2698           acipa(1,1)=a22
2699           acipa(1,2)=a23
2700           acipa(2,1)=a32
2701           acipa(2,2)=a33
2702           a22=-a22
2703           a23=-a23
2704           do l=1,2
2705             do k=1,3
2706               agg(k,l)=-agg(k,l)
2707               aggi(k,l)=-aggi(k,l)
2708               aggi1(k,l)=-aggi1(k,l)
2709               aggj(k,l)=-aggj(k,l)
2710               aggj1(k,l)=-aggj1(k,l)
2711             enddo
2712           enddo
2713           if (j.lt.nres-1) then
2714             a22=-a22
2715             a32=-a32
2716             do l=1,3,2
2717               do k=1,3
2718                 agg(k,l)=-agg(k,l)
2719                 aggi(k,l)=-aggi(k,l)
2720                 aggi1(k,l)=-aggi1(k,l)
2721                 aggj(k,l)=-aggj(k,l)
2722                 aggj1(k,l)=-aggj1(k,l)
2723               enddo
2724             enddo
2725           else
2726             a22=-a22
2727             a23=-a23
2728             a32=-a32
2729             a33=-a33
2730             do l=1,4
2731               do k=1,3
2732                 agg(k,l)=-agg(k,l)
2733                 aggi(k,l)=-aggi(k,l)
2734                 aggi1(k,l)=-aggi1(k,l)
2735                 aggj(k,l)=-aggj(k,l)
2736                 aggj1(k,l)=-aggj1(k,l)
2737               enddo
2738             enddo
2739           endif
2740           ENDIF ! WCORR
2741 11111     continue
2742           IF (wel_loc.gt.0.0d0) THEN
2743 C Contribution to the local-electrostatic energy coming from the i-j pair
2744           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2745      &     +a33*muij(4)
2746 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2747 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2748           if (shield_mode.eq.0) then
2749            fac_shield(i)=1.0
2750            fac_shield(j)=1.0
2751 C          else
2752 C           fac_shield(i)=0.4
2753 C           fac_shield(j)=0.6
2754           endif
2755           eel_loc_ij=eel_loc_ij
2756      &    *fac_shield(i)*fac_shield(j)
2757           eel_loc=eel_loc+eel_loc_ij
2758 C Partial derivatives in virtual-bond dihedral angles gamma
2759           if (calc_grad) then
2760           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2761      &  (shield_mode.gt.0)) then
2762 C          print *,i,j
2763
2764           do ilist=1,ishield_list(i)
2765            iresshield=shield_list(ilist,i)
2766            do k=1,3
2767            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2768      &                                          /fac_shield(i)
2769 C     &      *2.0
2770            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2771      &              rlocshield
2772      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2773             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2774      &      +rlocshield
2775            enddo
2776           enddo
2777           do ilist=1,ishield_list(j)
2778            iresshield=shield_list(ilist,j)
2779            do k=1,3
2780            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2781      &                                       /fac_shield(j)
2782 C     &     *2.0
2783            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2784      &              rlocshield
2785      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2786            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2787      &             +rlocshield
2788
2789            enddo
2790           enddo
2791           do k=1,3
2792             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2793      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2794             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2795      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2796             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2797      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2798             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2799      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2800            enddo
2801            endif
2802           if (i.gt.1)
2803      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2804      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2805      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2806      &    *fac_shield(i)*fac_shield(j)
2807           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2808      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2809      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2810      &    *fac_shield(i)*fac_shield(j)
2811
2812 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2813 cd          write(iout,*) 'agg  ',agg
2814 cd          write(iout,*) 'aggi ',aggi
2815 cd          write(iout,*) 'aggi1',aggi1
2816 cd          write(iout,*) 'aggj ',aggj
2817 cd          write(iout,*) 'aggj1',aggj1
2818
2819 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2820           do l=1,3
2821             ggg(l)=agg(l,1)*muij(1)+
2822      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2823      &    *fac_shield(i)*fac_shield(j)
2824
2825           enddo
2826           do k=i+2,j2
2827             do l=1,3
2828               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2829             enddo
2830           enddo
2831 C Remaining derivatives of eello
2832           do l=1,3
2833             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2834      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2835      &    *fac_shield(i)*fac_shield(j)
2836
2837             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2838      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2839      &    *fac_shield(i)*fac_shield(j)
2840
2841             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2842      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2843      &    *fac_shield(i)*fac_shield(j)
2844
2845             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2846      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2847      &    *fac_shield(i)*fac_shield(j)
2848
2849           enddo
2850           endif
2851           ENDIF
2852           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2853 C Contributions from turns
2854             a_temp(1,1)=a22
2855             a_temp(1,2)=a23
2856             a_temp(2,1)=a32
2857             a_temp(2,2)=a33
2858             call eturn34(i,j,eello_turn3,eello_turn4)
2859           endif
2860 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2861           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2862 C
2863 C Calculate the contact function. The ith column of the array JCONT will
2864 C contain the numbers of atoms that make contacts with the atom I (of numbers
2865 C greater than I). The arrays FACONT and GACONT will contain the values of
2866 C the contact function and its derivative.
2867 c           r0ij=1.02D0*rpp(iteli,itelj)
2868 c           r0ij=1.11D0*rpp(iteli,itelj)
2869             r0ij=2.20D0*rpp(iteli,itelj)
2870 c           r0ij=1.55D0*rpp(iteli,itelj)
2871             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2872             if (fcont.gt.0.0D0) then
2873               num_conti=num_conti+1
2874               if (num_conti.gt.maxconts) then
2875                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2876      &                         ' will skip next contacts for this conf.'
2877               else
2878                 jcont_hb(num_conti,i)=j
2879                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2880      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2881 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2882 C  terms.
2883                 d_cont(num_conti,i)=rij
2884 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2885 C     --- Electrostatic-interaction matrix ---
2886                 a_chuj(1,1,num_conti,i)=a22
2887                 a_chuj(1,2,num_conti,i)=a23
2888                 a_chuj(2,1,num_conti,i)=a32
2889                 a_chuj(2,2,num_conti,i)=a33
2890 C     --- Gradient of rij
2891                 do kkk=1,3
2892                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2893                 enddo
2894 c             if (i.eq.1) then
2895 c                a_chuj(1,1,num_conti,i)=-0.61d0
2896 c                a_chuj(1,2,num_conti,i)= 0.4d0
2897 c                a_chuj(2,1,num_conti,i)= 0.65d0
2898 c                a_chuj(2,2,num_conti,i)= 0.50d0
2899 c             else if (i.eq.2) then
2900 c                a_chuj(1,1,num_conti,i)= 0.0d0
2901 c                a_chuj(1,2,num_conti,i)= 0.0d0
2902 c                a_chuj(2,1,num_conti,i)= 0.0d0
2903 c                a_chuj(2,2,num_conti,i)= 0.0d0
2904 c             endif
2905 C     --- and its gradients
2906 cd                write (iout,*) 'i',i,' j',j
2907 cd                do kkk=1,3
2908 cd                write (iout,*) 'iii 1 kkk',kkk
2909 cd                write (iout,*) agg(kkk,:)
2910 cd                enddo
2911 cd                do kkk=1,3
2912 cd                write (iout,*) 'iii 2 kkk',kkk
2913 cd                write (iout,*) aggi(kkk,:)
2914 cd                enddo
2915 cd                do kkk=1,3
2916 cd                write (iout,*) 'iii 3 kkk',kkk
2917 cd                write (iout,*) aggi1(kkk,:)
2918 cd                enddo
2919 cd                do kkk=1,3
2920 cd                write (iout,*) 'iii 4 kkk',kkk
2921 cd                write (iout,*) aggj(kkk,:)
2922 cd                enddo
2923 cd                do kkk=1,3
2924 cd                write (iout,*) 'iii 5 kkk',kkk
2925 cd                write (iout,*) aggj1(kkk,:)
2926 cd                enddo
2927                 kkll=0
2928                 do k=1,2
2929                   do l=1,2
2930                     kkll=kkll+1
2931                     do m=1,3
2932                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2933                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2934                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2935                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2936                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2937 c                      do mm=1,5
2938 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2939 c                      enddo
2940                     enddo
2941                   enddo
2942                 enddo
2943                 ENDIF
2944                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2945 C Calculate contact energies
2946                 cosa4=4.0D0*cosa
2947                 wij=cosa-3.0D0*cosb*cosg
2948                 cosbg1=cosb+cosg
2949                 cosbg2=cosb-cosg
2950 c               fac3=dsqrt(-ael6i)/r0ij**3
2951                 fac3=dsqrt(-ael6i)*r3ij
2952                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2953                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2954                 if (shield_mode.eq.0) then
2955                 fac_shield(i)=1.0d0
2956                 fac_shield(j)=1.0d0
2957                 else
2958                 ees0plist(num_conti,i)=j
2959 C                fac_shield(i)=0.4d0
2960 C                fac_shield(j)=0.6d0
2961                 endif
2962 c               ees0mij=0.0D0
2963                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2964      &          *fac_shield(i)*fac_shield(j)
2965
2966                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2967      &          *fac_shield(i)*fac_shield(j)
2968
2969 C Diagnostics. Comment out or remove after debugging!
2970 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2971 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2972 c               ees0m(num_conti,i)=0.0D0
2973 C End diagnostics.
2974 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2975 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2976                 facont_hb(num_conti,i)=fcont
2977                 if (calc_grad) then
2978 C Angular derivatives of the contact function
2979                 ees0pij1=fac3/ees0pij
2980                 ees0mij1=fac3/ees0mij
2981                 fac3p=-3.0D0*fac3*rrmij
2982                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2983                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2984 c               ees0mij1=0.0D0
2985                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2986                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2987                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2988                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2989                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2990                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2991                 ecosap=ecosa1+ecosa2
2992                 ecosbp=ecosb1+ecosb2
2993                 ecosgp=ecosg1+ecosg2
2994                 ecosam=ecosa1-ecosa2
2995                 ecosbm=ecosb1-ecosb2
2996                 ecosgm=ecosg1-ecosg2
2997 C Diagnostics
2998 c               ecosap=ecosa1
2999 c               ecosbp=ecosb1
3000 c               ecosgp=ecosg1
3001 c               ecosam=0.0D0
3002 c               ecosbm=0.0D0
3003 c               ecosgm=0.0D0
3004 C End diagnostics
3005                 fprimcont=fprimcont/rij
3006 cd              facont_hb(num_conti,i)=1.0D0
3007 C Following line is for diagnostics.
3008 cd              fprimcont=0.0D0
3009                 do k=1,3
3010                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3011                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3012                 enddo
3013                 do k=1,3
3014                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3015                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3016                 enddo
3017                 gggp(1)=gggp(1)+ees0pijp*xj
3018                 gggp(2)=gggp(2)+ees0pijp*yj
3019                 gggp(3)=gggp(3)+ees0pijp*zj
3020                 gggm(1)=gggm(1)+ees0mijp*xj
3021                 gggm(2)=gggm(2)+ees0mijp*yj
3022                 gggm(3)=gggm(3)+ees0mijp*zj
3023 C Derivatives due to the contact function
3024                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3025                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3026                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3027                 do k=1,3
3028                   ghalfp=0.5D0*gggp(k)
3029                   ghalfm=0.5D0*gggm(k)
3030                   gacontp_hb1(k,num_conti,i)=ghalfp
3031      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3032      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3033      &          *fac_shield(i)*fac_shield(j)
3034
3035                   gacontp_hb2(k,num_conti,i)=ghalfp
3036      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3037      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3038      &          *fac_shield(i)*fac_shield(j)
3039
3040                   gacontp_hb3(k,num_conti,i)=gggp(k)
3041      &          *fac_shield(i)*fac_shield(j)
3042
3043                   gacontm_hb1(k,num_conti,i)=ghalfm
3044      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3045      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3046      &          *fac_shield(i)*fac_shield(j)
3047
3048                   gacontm_hb2(k,num_conti,i)=ghalfm
3049      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3050      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3051      &          *fac_shield(i)*fac_shield(j)
3052
3053                   gacontm_hb3(k,num_conti,i)=gggm(k)
3054      &          *fac_shield(i)*fac_shield(j)
3055
3056                 enddo
3057                 endif
3058 C Diagnostics. Comment out or remove after debugging!
3059 cdiag           do k=1,3
3060 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3061 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3062 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3063 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3064 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3065 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3066 cdiag           enddo
3067               ENDIF ! wcorr
3068               endif  ! num_conti.le.maxconts
3069             endif  ! fcont.gt.0
3070           endif    ! j.gt.i+1
3071  1216     continue
3072         enddo ! j
3073         num_cont_hb(i)=num_conti
3074  1215   continue
3075       enddo   ! i
3076 cd      do i=1,nres
3077 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3078 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3079 cd      enddo
3080 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3081 ccc      eel_loc=eel_loc+eello_turn3
3082       return
3083       end
3084 C-----------------------------------------------------------------------------
3085       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3086 C Third- and fourth-order contributions from turns
3087       implicit real*8 (a-h,o-z)
3088       include 'DIMENSIONS'
3089       include 'sizesclu.dat'
3090       include 'COMMON.IOUNITS'
3091       include 'COMMON.GEO'
3092       include 'COMMON.VAR'
3093       include 'COMMON.LOCAL'
3094       include 'COMMON.CHAIN'
3095       include 'COMMON.DERIV'
3096       include 'COMMON.INTERACT'
3097       include 'COMMON.CONTACTS'
3098       include 'COMMON.TORSION'
3099       include 'COMMON.VECTORS'
3100       include 'COMMON.FFIELD'
3101       include 'COMMON.SHIELD'
3102       include 'COMMON.CONTROL'
3103
3104       dimension ggg(3)
3105       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3106      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3107      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3108       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3109      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3110       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3111       if (j.eq.i+2) then
3112       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3113 C changes suggested by Ana to avoid out of bounds
3114 C     & .or.((i+5).gt.nres)
3115 C     & .or.((i-1).le.0)
3116 C end of changes suggested by Ana
3117      &    .or. itype(i+2).eq.ntyp1
3118      &    .or. itype(i+3).eq.ntyp1
3119 C     &    .or. itype(i+5).eq.ntyp1
3120 C     &    .or. itype(i).eq.ntyp1
3121 C     &    .or. itype(i-1).eq.ntyp1
3122      &    ) goto 179
3123
3124 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3125 C
3126 C               Third-order contributions
3127 C
3128 C                 (i+2)o----(i+3)
3129 C                      | |
3130 C                      | |
3131 C                 (i+1)o----i
3132 C
3133 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3134 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3135         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3136         call transpose2(auxmat(1,1),auxmat1(1,1))
3137         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3138         if (shield_mode.eq.0) then
3139         fac_shield(i)=1.0
3140         fac_shield(j)=1.0
3141 C        else
3142 C        fac_shield(i)=0.4
3143 C        fac_shield(j)=0.6
3144         endif
3145         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3146      &  *fac_shield(i)*fac_shield(j)
3147         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3148      &  *fac_shield(i)*fac_shield(j)
3149
3150 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3151 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3152 cd     &    ' eello_turn3_num',4*eello_turn3_num
3153         if (calc_grad) then
3154 C Derivatives in shield mode
3155           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3156      &  (shield_mode.gt.0)) then
3157 C          print *,i,j
3158
3159           do ilist=1,ishield_list(i)
3160            iresshield=shield_list(ilist,i)
3161            do k=1,3
3162            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3163 C     &      *2.0
3164            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3165      &              rlocshield
3166      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3167             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3168      &      +rlocshield
3169            enddo
3170           enddo
3171           do ilist=1,ishield_list(j)
3172            iresshield=shield_list(ilist,j)
3173            do k=1,3
3174            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3175 C     &     *2.0
3176            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3177      &              rlocshield
3178      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3179            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3180      &             +rlocshield
3181
3182            enddo
3183           enddo
3184
3185           do k=1,3
3186             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3187      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3188             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3189      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3190             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3191      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3192             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3193      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3194            enddo
3195            endif
3196
3197 C Derivatives in gamma(i)
3198         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3199         call transpose2(auxmat2(1,1),pizda(1,1))
3200         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3201         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3202      &   *fac_shield(i)*fac_shield(j)
3203
3204 C Derivatives in gamma(i+1)
3205         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3206         call transpose2(auxmat2(1,1),pizda(1,1))
3207         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3208         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3209      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3210      &   *fac_shield(i)*fac_shield(j)
3211
3212 C Cartesian derivatives
3213         do l=1,3
3214           a_temp(1,1)=aggi(l,1)
3215           a_temp(1,2)=aggi(l,2)
3216           a_temp(2,1)=aggi(l,3)
3217           a_temp(2,2)=aggi(l,4)
3218           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3219           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3220      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3221      &   *fac_shield(i)*fac_shield(j)
3222
3223           a_temp(1,1)=aggi1(l,1)
3224           a_temp(1,2)=aggi1(l,2)
3225           a_temp(2,1)=aggi1(l,3)
3226           a_temp(2,2)=aggi1(l,4)
3227           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3228           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3229      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3230      &   *fac_shield(i)*fac_shield(j)
3231
3232           a_temp(1,1)=aggj(l,1)
3233           a_temp(1,2)=aggj(l,2)
3234           a_temp(2,1)=aggj(l,3)
3235           a_temp(2,2)=aggj(l,4)
3236           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3237           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3238      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3239      &   *fac_shield(i)*fac_shield(j)
3240
3241           a_temp(1,1)=aggj1(l,1)
3242           a_temp(1,2)=aggj1(l,2)
3243           a_temp(2,1)=aggj1(l,3)
3244           a_temp(2,2)=aggj1(l,4)
3245           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3246           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3247      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3248      &   *fac_shield(i)*fac_shield(j)
3249
3250         enddo
3251         endif
3252   179 continue
3253       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3254       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3255 C changes suggested by Ana to avoid out of bounds
3256 C     & .or.((i+5).gt.nres)
3257 C     & .or.((i-1).le.0)
3258 C end of changes suggested by Ana
3259      &    .or. itype(i+3).eq.ntyp1
3260      &    .or. itype(i+4).eq.ntyp1
3261 C     &    .or. itype(i+5).eq.ntyp1
3262      &    .or. itype(i).eq.ntyp1
3263 C     &    .or. itype(i-1).eq.ntyp1
3264      &    ) goto 178
3265
3266 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3267 C
3268 C               Fourth-order contributions
3269 C
3270 C                 (i+3)o----(i+4)
3271 C                     /  |
3272 C               (i+2)o   |
3273 C                     \  |
3274 C                 (i+1)o----i
3275 C
3276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3277 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3278         iti1=itortyp(itype(i+1))
3279         iti2=itortyp(itype(i+2))
3280         iti3=itortyp(itype(i+3))
3281         call transpose2(EUg(1,1,i+1),e1t(1,1))
3282         call transpose2(Eug(1,1,i+2),e2t(1,1))
3283         call transpose2(Eug(1,1,i+3),e3t(1,1))
3284         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3285         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3286         s1=scalar2(b1(1,iti2),auxvec(1))
3287         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3288         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3289         s2=scalar2(b1(1,iti1),auxvec(1))
3290         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3291         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3292         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3293         if (shield_mode.eq.0) then
3294         fac_shield(i)=1.0
3295         fac_shield(j)=1.0
3296 C        else
3297 C        fac_shield(i)=0.4
3298 C        fac_shield(j)=0.6
3299         endif
3300         eello_turn4=eello_turn4-(s1+s2+s3)
3301      &  *fac_shield(i)*fac_shield(j)
3302         eello_t4=-(s1+s2+s3)
3303      &  *fac_shield(i)*fac_shield(j)
3304
3305 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3306 cd     &    ' eello_turn4_num',8*eello_turn4_num
3307 C Derivatives in gamma(i)
3308         if (calc_grad) then
3309           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3310      &  (shield_mode.gt.0)) then
3311 C          print *,i,j
3312
3313           do ilist=1,ishield_list(i)
3314            iresshield=shield_list(ilist,i)
3315            do k=1,3
3316            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3317 C     &      *2.0
3318            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3319      &              rlocshield
3320      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3321             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3322      &      +rlocshield
3323            enddo
3324           enddo
3325           do ilist=1,ishield_list(j)
3326            iresshield=shield_list(ilist,j)
3327            do k=1,3
3328            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3329 C     &     *2.0
3330            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3331      &              rlocshield
3332      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3333            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3334      &             +rlocshield
3335
3336            enddo
3337           enddo
3338
3339           do k=1,3
3340             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3341      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3342             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3343      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3344             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3345      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3346             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3347      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3348            enddo
3349            endif
3350
3351         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3352         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3353         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3354         s1=scalar2(b1(1,iti2),auxvec(1))
3355         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3356         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3357         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3358      &  *fac_shield(i)*fac_shield(j)
3359
3360 C Derivatives in gamma(i+1)
3361         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3362         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3363         s2=scalar2(b1(1,iti1),auxvec(1))
3364         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3365         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3366         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3367         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3368      &  *fac_shield(i)*fac_shield(j)
3369
3370 C Derivatives in gamma(i+2)
3371         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3372         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3373         s1=scalar2(b1(1,iti2),auxvec(1))
3374         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3375         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3376         s2=scalar2(b1(1,iti1),auxvec(1))
3377         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3378         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3379         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3380         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3381      &  *fac_shield(i)*fac_shield(j)
3382
3383 C Cartesian derivatives
3384 C Derivatives of this turn contributions in DC(i+2)
3385         if (j.lt.nres-1) then
3386           do l=1,3
3387             a_temp(1,1)=agg(l,1)
3388             a_temp(1,2)=agg(l,2)
3389             a_temp(2,1)=agg(l,3)
3390             a_temp(2,2)=agg(l,4)
3391             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3392             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3393             s1=scalar2(b1(1,iti2),auxvec(1))
3394             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3395             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3396             s2=scalar2(b1(1,iti1),auxvec(1))
3397             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3398             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3399             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3400             ggg(l)=-(s1+s2+s3)
3401             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3402      &  *fac_shield(i)*fac_shield(j)
3403
3404           enddo
3405         endif
3406 C Remaining derivatives of this turn contribution
3407         do l=1,3
3408           a_temp(1,1)=aggi(l,1)
3409           a_temp(1,2)=aggi(l,2)
3410           a_temp(2,1)=aggi(l,3)
3411           a_temp(2,2)=aggi(l,4)
3412           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3413           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3414           s1=scalar2(b1(1,iti2),auxvec(1))
3415           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3416           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3417           s2=scalar2(b1(1,iti1),auxvec(1))
3418           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3419           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3420           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3421           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3422      &  *fac_shield(i)*fac_shield(j)
3423
3424           a_temp(1,1)=aggi1(l,1)
3425           a_temp(1,2)=aggi1(l,2)
3426           a_temp(2,1)=aggi1(l,3)
3427           a_temp(2,2)=aggi1(l,4)
3428           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3429           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3430           s1=scalar2(b1(1,iti2),auxvec(1))
3431           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3432           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3433           s2=scalar2(b1(1,iti1),auxvec(1))
3434           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3435           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3436           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3437           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3438      &  *fac_shield(i)*fac_shield(j)
3439
3440           a_temp(1,1)=aggj(l,1)
3441           a_temp(1,2)=aggj(l,2)
3442           a_temp(2,1)=aggj(l,3)
3443           a_temp(2,2)=aggj(l,4)
3444           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3445           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3446           s1=scalar2(b1(1,iti2),auxvec(1))
3447           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3448           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3449           s2=scalar2(b1(1,iti1),auxvec(1))
3450           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3451           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3452           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3453           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3454      &  *fac_shield(i)*fac_shield(j)
3455
3456           a_temp(1,1)=aggj1(l,1)
3457           a_temp(1,2)=aggj1(l,2)
3458           a_temp(2,1)=aggj1(l,3)
3459           a_temp(2,2)=aggj1(l,4)
3460           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3461           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3462           s1=scalar2(b1(1,iti2),auxvec(1))
3463           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3464           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3465           s2=scalar2(b1(1,iti1),auxvec(1))
3466           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3467           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3468           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3469           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3470      &  *fac_shield(i)*fac_shield(j)
3471
3472         enddo
3473         endif
3474   178 continue
3475       endif
3476       return
3477       end
3478 C-----------------------------------------------------------------------------
3479       subroutine vecpr(u,v,w)
3480       implicit real*8(a-h,o-z)
3481       dimension u(3),v(3),w(3)
3482       w(1)=u(2)*v(3)-u(3)*v(2)
3483       w(2)=-u(1)*v(3)+u(3)*v(1)
3484       w(3)=u(1)*v(2)-u(2)*v(1)
3485       return
3486       end
3487 C-----------------------------------------------------------------------------
3488       subroutine unormderiv(u,ugrad,unorm,ungrad)
3489 C This subroutine computes the derivatives of a normalized vector u, given
3490 C the derivatives computed without normalization conditions, ugrad. Returns
3491 C ungrad.
3492       implicit none
3493       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3494       double precision vec(3)
3495       double precision scalar
3496       integer i,j
3497 c      write (2,*) 'ugrad',ugrad
3498 c      write (2,*) 'u',u
3499       do i=1,3
3500         vec(i)=scalar(ugrad(1,i),u(1))
3501       enddo
3502 c      write (2,*) 'vec',vec
3503       do i=1,3
3504         do j=1,3
3505           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3506         enddo
3507       enddo
3508 c      write (2,*) 'ungrad',ungrad
3509       return
3510       end
3511 C-----------------------------------------------------------------------------
3512       subroutine escp(evdw2,evdw2_14)
3513 C
3514 C This subroutine calculates the excluded-volume interaction energy between
3515 C peptide-group centers and side chains and its gradient in virtual-bond and
3516 C side-chain vectors.
3517 C
3518       implicit real*8 (a-h,o-z)
3519       include 'DIMENSIONS'
3520       include 'sizesclu.dat'
3521       include 'COMMON.GEO'
3522       include 'COMMON.VAR'
3523       include 'COMMON.LOCAL'
3524       include 'COMMON.CHAIN'
3525       include 'COMMON.DERIV'
3526       include 'COMMON.INTERACT'
3527       include 'COMMON.FFIELD'
3528       include 'COMMON.IOUNITS'
3529       dimension ggg(3)
3530       evdw2=0.0D0
3531       evdw2_14=0.0d0
3532 cd    print '(a)','Enter ESCP'
3533 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3534 c     &  ' scal14',scal14
3535       do i=iatscp_s,iatscp_e
3536         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3537         iteli=itel(i)
3538 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3539 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3540         if (iteli.eq.0) goto 1225
3541         xi=0.5D0*(c(1,i)+c(1,i+1))
3542         yi=0.5D0*(c(2,i)+c(2,i+1))
3543         zi=0.5D0*(c(3,i)+c(3,i+1))
3544 C    Returning the ith atom to box
3545           xi=mod(xi,boxxsize)
3546           if (xi.lt.0) xi=xi+boxxsize
3547           yi=mod(yi,boxysize)
3548           if (yi.lt.0) yi=yi+boxysize
3549           zi=mod(zi,boxzsize)
3550           if (zi.lt.0) zi=zi+boxzsize
3551
3552         do iint=1,nscp_gr(i)
3553
3554         do j=iscpstart(i,iint),iscpend(i,iint)
3555           itypj=iabs(itype(j))
3556           if (itypj.eq.ntyp1) cycle
3557 C Uncomment following three lines for SC-p interactions
3558 c         xj=c(1,nres+j)-xi
3559 c         yj=c(2,nres+j)-yi
3560 c         zj=c(3,nres+j)-zi
3561 C Uncomment following three lines for Ca-p interactions
3562           xj=c(1,j)
3563           yj=c(2,j)
3564           zj=c(3,j)
3565 C returning the jth atom to box
3566           xj=mod(xj,boxxsize)
3567           if (xj.lt.0) xj=xj+boxxsize
3568           yj=mod(yj,boxysize)
3569           if (yj.lt.0) yj=yj+boxysize
3570           zj=mod(zj,boxzsize)
3571           if (zj.lt.0) zj=zj+boxzsize
3572       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3573       xj_safe=xj
3574       yj_safe=yj
3575       zj_safe=zj
3576       subchap=0
3577 C Finding the closest jth atom
3578       do xshift=-1,1
3579       do yshift=-1,1
3580       do zshift=-1,1
3581           xj=xj_safe+xshift*boxxsize
3582           yj=yj_safe+yshift*boxysize
3583           zj=zj_safe+zshift*boxzsize
3584           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3585           if(dist_temp.lt.dist_init) then
3586             dist_init=dist_temp
3587             xj_temp=xj
3588             yj_temp=yj
3589             zj_temp=zj
3590             subchap=1
3591           endif
3592        enddo
3593        enddo
3594        enddo
3595        if (subchap.eq.1) then
3596           xj=xj_temp-xi
3597           yj=yj_temp-yi
3598           zj=zj_temp-zi
3599        else
3600           xj=xj_safe-xi
3601           yj=yj_safe-yi
3602           zj=zj_safe-zi
3603        endif
3604
3605           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3606 C sss is scaling function for smoothing the cutoff gradient otherwise
3607 C the gradient would not be continuouse
3608           sss=sscale(1.0d0/(dsqrt(rrij)))
3609           if (sss.le.0.0d0) cycle
3610           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3611           fac=rrij**expon2
3612           e1=fac*fac*aad(itypj,iteli)
3613           e2=fac*bad(itypj,iteli)
3614           if (iabs(j-i) .le. 2) then
3615             e1=scal14*e1
3616             e2=scal14*e2
3617             evdw2_14=evdw2_14+(e1+e2)*sss
3618           endif
3619           evdwij=e1+e2
3620 c          write (iout,*) i,j,evdwij
3621           evdw2=evdw2+evdwij*sss
3622           if (calc_grad) then
3623 C
3624 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3625 C
3626            fac=-(evdwij+e1)*rrij*sss
3627            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3628           ggg(1)=xj*fac
3629           ggg(2)=yj*fac
3630           ggg(3)=zj*fac
3631           if (j.lt.i) then
3632 cd          write (iout,*) 'j<i'
3633 C Uncomment following three lines for SC-p interactions
3634 c           do k=1,3
3635 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3636 c           enddo
3637           else
3638 cd          write (iout,*) 'j>i'
3639             do k=1,3
3640               ggg(k)=-ggg(k)
3641 C Uncomment following line for SC-p interactions
3642 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3643             enddo
3644           endif
3645           do k=1,3
3646             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3647           enddo
3648           kstart=min0(i+1,j)
3649           kend=max0(i-1,j-1)
3650 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3651 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3652           do k=kstart,kend
3653             do l=1,3
3654               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3655             enddo
3656           enddo
3657           endif
3658         enddo
3659         enddo ! iint
3660  1225   continue
3661       enddo ! i
3662       do i=1,nct
3663         do j=1,3
3664           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3665           gradx_scp(j,i)=expon*gradx_scp(j,i)
3666         enddo
3667       enddo
3668 C******************************************************************************
3669 C
3670 C                              N O T E !!!
3671 C
3672 C To save time the factor EXPON has been extracted from ALL components
3673 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3674 C use!
3675 C
3676 C******************************************************************************
3677       return
3678       end
3679 C--------------------------------------------------------------------------
3680       subroutine edis(ehpb)
3681 C
3682 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3683 C
3684       implicit real*8 (a-h,o-z)
3685       include 'DIMENSIONS'
3686       include 'sizesclu.dat'
3687       include 'COMMON.SBRIDGE'
3688       include 'COMMON.CHAIN'
3689       include 'COMMON.DERIV'
3690       include 'COMMON.VAR'
3691       include 'COMMON.INTERACT'
3692       include 'COMMON.CONTROL'
3693       dimension ggg(3)
3694       ehpb=0.0D0
3695 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3696 cd    print *,'link_start=',link_start,' link_end=',link_end
3697       if (link_end.eq.0) return
3698       do i=link_start,link_end
3699 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3700 C CA-CA distance used in regularization of structure.
3701         ii=ihpb(i)
3702         jj=jhpb(i)
3703 C iii and jjj point to the residues for which the distance is assigned.
3704         if (ii.gt.nres) then
3705           iii=ii-nres
3706           jjj=jj-nres
3707         else
3708           iii=ii
3709           jjj=jj
3710         endif
3711 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3712 C    distance and angle dependent SS bond potential.
3713 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3714 C     &  iabs(itype(jjj)).eq.1) then
3715 C          call ssbond_ene(iii,jjj,eij)
3716 C          ehpb=ehpb+2*eij
3717 C        else
3718        if (.not.dyn_ss .and. i.le.nss) then
3719          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3720      & iabs(itype(jjj)).eq.1) then
3721           call ssbond_ene(iii,jjj,eij)
3722           ehpb=ehpb+2*eij
3723            endif !ii.gt.neres
3724         else if (ii.gt.nres .and. jj.gt.nres) then
3725 c Restraints from contact prediction
3726           dd=dist(ii,jj)
3727           if (constr_dist.eq.11) then
3728 C            ehpb=ehpb+fordepth(i)**4.0d0
3729 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3730             ehpb=ehpb+fordepth(i)**4.0d0
3731      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3732             fac=fordepth(i)**4.0d0
3733      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3734 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3735 C     &    ehpb,fordepth(i),dd
3736 C             print *,"TUTU"
3737 C            write(iout,*) ehpb,"atu?"
3738 C            ehpb,"tu?"
3739 C            fac=fordepth(i)**4.0d0
3740 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3741            else !constr_dist.eq.11
3742           if (dhpb1(i).gt.0.0d0) then
3743             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3744             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3745 c            write (iout,*) "beta nmr",
3746 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3747           else !dhpb(i).gt.0.00
3748
3749 C Calculate the distance between the two points and its difference from the
3750 C target distance.
3751         dd=dist(ii,jj)
3752         rdis=dd-dhpb(i)
3753 C Get the force constant corresponding to this distance.
3754         waga=forcon(i)
3755 C Calculate the contribution to energy.
3756         ehpb=ehpb+waga*rdis*rdis
3757 C
3758 C Evaluate gradient.
3759 C
3760         fac=waga*rdis/dd
3761         endif !dhpb(i).gt.0
3762         endif
3763 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3764 cd   &   ' waga=',waga,' fac=',fac
3765         do j=1,3
3766           ggg(j)=fac*(c(j,jj)-c(j,ii))
3767         enddo
3768 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3769 C If this is a SC-SC distance, we need to calculate the contributions to the
3770 C Cartesian gradient in the SC vectors (ghpbx).
3771         if (iii.lt.ii) then
3772           do j=1,3
3773             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3774             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3775           enddo
3776         endif
3777         else !ii.gt.nres
3778 C          write(iout,*) "before"
3779           dd=dist(ii,jj)
3780 C          write(iout,*) "after",dd
3781           if (constr_dist.eq.11) then
3782             ehpb=ehpb+fordepth(i)**4.0d0
3783      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3784             fac=fordepth(i)**4.0d0
3785      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3786 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3787 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3788 C            print *,ehpb,"tu?"
3789 C            write(iout,*) ehpb,"btu?",
3790 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3791 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3792 C     &    ehpb,fordepth(i),dd
3793            else
3794           if (dhpb1(i).gt.0.0d0) then
3795             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3796             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3797 c            write (iout,*) "alph nmr",
3798 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3799           else
3800             rdis=dd-dhpb(i)
3801 C Get the force constant corresponding to this distance.
3802             waga=forcon(i)
3803 C Calculate the contribution to energy.
3804             ehpb=ehpb+waga*rdis*rdis
3805 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3806 C
3807 C Evaluate gradient.
3808 C
3809             fac=waga*rdis/dd
3810           endif
3811           endif
3812         do j=1,3
3813           ggg(j)=fac*(c(j,jj)-c(j,ii))
3814         enddo
3815 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3816 C If this is a SC-SC distance, we need to calculate the contributions to the
3817 C Cartesian gradient in the SC vectors (ghpbx).
3818         if (iii.lt.ii) then
3819           do j=1,3
3820             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3821             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3822           enddo
3823         endif
3824         do j=iii,jjj-1
3825           do k=1,3
3826             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3827           enddo
3828         enddo
3829         endif
3830       enddo
3831       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3832       return
3833       end
3834 C--------------------------------------------------------------------------
3835       subroutine ssbond_ene(i,j,eij)
3836 C
3837 C Calculate the distance and angle dependent SS-bond potential energy
3838 C using a free-energy function derived based on RHF/6-31G** ab initio
3839 C calculations of diethyl disulfide.
3840 C
3841 C A. Liwo and U. Kozlowska, 11/24/03
3842 C
3843       implicit real*8 (a-h,o-z)
3844       include 'DIMENSIONS'
3845       include 'sizesclu.dat'
3846       include 'COMMON.SBRIDGE'
3847       include 'COMMON.CHAIN'
3848       include 'COMMON.DERIV'
3849       include 'COMMON.LOCAL'
3850       include 'COMMON.INTERACT'
3851       include 'COMMON.VAR'
3852       include 'COMMON.IOUNITS'
3853       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3854       itypi=iabs(itype(i))
3855       xi=c(1,nres+i)
3856       yi=c(2,nres+i)
3857       zi=c(3,nres+i)
3858       dxi=dc_norm(1,nres+i)
3859       dyi=dc_norm(2,nres+i)
3860       dzi=dc_norm(3,nres+i)
3861       dsci_inv=dsc_inv(itypi)
3862       itypj=iabs(itype(j))
3863       dscj_inv=dsc_inv(itypj)
3864       xj=c(1,nres+j)-xi
3865       yj=c(2,nres+j)-yi
3866       zj=c(3,nres+j)-zi
3867       dxj=dc_norm(1,nres+j)
3868       dyj=dc_norm(2,nres+j)
3869       dzj=dc_norm(3,nres+j)
3870       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3871       rij=dsqrt(rrij)
3872       erij(1)=xj*rij
3873       erij(2)=yj*rij
3874       erij(3)=zj*rij
3875       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3876       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3877       om12=dxi*dxj+dyi*dyj+dzi*dzj
3878       do k=1,3
3879         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3880         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3881       enddo
3882       rij=1.0d0/rij
3883       deltad=rij-d0cm
3884       deltat1=1.0d0-om1
3885       deltat2=1.0d0+om2
3886       deltat12=om2-om1+2.0d0
3887       cosphi=om12-om1*om2
3888       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3889      &  +akct*deltad*deltat12
3890      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3891 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3892 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3893 c     &  " deltat12",deltat12," eij",eij
3894       ed=2*akcm*deltad+akct*deltat12
3895       pom1=akct*deltad
3896       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3897       eom1=-2*akth*deltat1-pom1-om2*pom2
3898       eom2= 2*akth*deltat2+pom1-om1*pom2
3899       eom12=pom2
3900       do k=1,3
3901         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3902       enddo
3903       do k=1,3
3904         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3905      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3906         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3907      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3908       enddo
3909 C
3910 C Calculate the components of the gradient in DC and X
3911 C
3912       do k=i,j-1
3913         do l=1,3
3914           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3915         enddo
3916       enddo
3917       return
3918       end
3919 C--------------------------------------------------------------------------
3920       subroutine ebond(estr)
3921 c
3922 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3923 c
3924       implicit real*8 (a-h,o-z)
3925       include 'DIMENSIONS'
3926       include 'sizesclu.dat'
3927       include 'COMMON.LOCAL'
3928       include 'COMMON.GEO'
3929       include 'COMMON.INTERACT'
3930       include 'COMMON.DERIV'
3931       include 'COMMON.VAR'
3932       include 'COMMON.CHAIN'
3933       include 'COMMON.IOUNITS'
3934       include 'COMMON.NAMES'
3935       include 'COMMON.FFIELD'
3936       include 'COMMON.CONTROL'
3937       logical energy_dec /.false./
3938       double precision u(3),ud(3)
3939       estr=0.0d0
3940       estr1=0.0d0
3941       do i=nnt+1,nct
3942         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3943 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3944 C          do j=1,3
3945 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3946 C     &      *dc(j,i-1)/vbld(i)
3947 C          enddo
3948 C          if (energy_dec) write(iout,*)
3949 C     &       "estr1",i,vbld(i),distchainmax,
3950 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3951 C        else
3952          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3953         diff = vbld(i)-vbldpDUM
3954          else
3955           diff = vbld(i)-vbldp0
3956 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3957          endif
3958           estr=estr+diff*diff
3959           do j=1,3
3960             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3961           enddo
3962 C        endif
3963 C        write (iout,'(a7,i5,4f7.3)')
3964 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3965       enddo
3966       estr=0.5d0*AKP*estr+estr1
3967 c
3968 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3969 c
3970       do i=nnt,nct
3971         iti=iabs(itype(i))
3972         if (iti.ne.10 .and. iti.ne.ntyp1) then
3973           nbi=nbondterm(iti)
3974           if (nbi.eq.1) then
3975             diff=vbld(i+nres)-vbldsc0(1,iti)
3976 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3977 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3978             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3979             do j=1,3
3980               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3981             enddo
3982           else
3983             do j=1,nbi
3984               diff=vbld(i+nres)-vbldsc0(j,iti)
3985               ud(j)=aksc(j,iti)*diff
3986               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3987             enddo
3988             uprod=u(1)
3989             do j=2,nbi
3990               uprod=uprod*u(j)
3991             enddo
3992             usum=0.0d0
3993             usumsqder=0.0d0
3994             do j=1,nbi
3995               uprod1=1.0d0
3996               uprod2=1.0d0
3997               do k=1,nbi
3998                 if (k.ne.j) then
3999                   uprod1=uprod1*u(k)
4000                   uprod2=uprod2*u(k)*u(k)
4001                 endif
4002               enddo
4003               usum=usum+uprod1
4004               usumsqder=usumsqder+ud(j)*uprod2
4005             enddo
4006 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4007 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4008             estr=estr+uprod/usum
4009             do j=1,3
4010              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4011             enddo
4012           endif
4013         endif
4014       enddo
4015       return
4016       end
4017 #ifdef CRYST_THETA
4018 C--------------------------------------------------------------------------
4019       subroutine ebend(etheta,ethetacnstr)
4020 C
4021 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4022 C angles gamma and its derivatives in consecutive thetas and gammas.
4023 C
4024       implicit real*8 (a-h,o-z)
4025       include 'DIMENSIONS'
4026       include 'sizesclu.dat'
4027       include 'COMMON.LOCAL'
4028       include 'COMMON.GEO'
4029       include 'COMMON.INTERACT'
4030       include 'COMMON.DERIV'
4031       include 'COMMON.VAR'
4032       include 'COMMON.CHAIN'
4033       include 'COMMON.IOUNITS'
4034       include 'COMMON.NAMES'
4035       include 'COMMON.FFIELD'
4036       include 'COMMON.TORCNSTR'
4037       common /calcthet/ term1,term2,termm,diffak,ratak,
4038      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4039      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4040       double precision y(2),z(2)
4041       delta=0.02d0*pi
4042 c      time11=dexp(-2*time)
4043 c      time12=1.0d0
4044       etheta=0.0D0
4045 c      write (iout,*) "nres",nres
4046 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4047 c      write (iout,*) ithet_start,ithet_end
4048       do i=ithet_start,ithet_end
4049         if (i.le.2) cycle
4050         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4051      &  .or.itype(i).eq.ntyp1) cycle
4052 C Zero the energy function and its derivative at 0 or pi.
4053         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4054         it=itype(i-1)
4055         ichir1=isign(1,itype(i-2))
4056         ichir2=isign(1,itype(i))
4057          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4058          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4059          if (itype(i-1).eq.10) then
4060           itype1=isign(10,itype(i-2))
4061           ichir11=isign(1,itype(i-2))
4062           ichir12=isign(1,itype(i-2))
4063           itype2=isign(10,itype(i))
4064           ichir21=isign(1,itype(i))
4065           ichir22=isign(1,itype(i))
4066          endif
4067          if (i.eq.3) then
4068           y(1)=0.0D0
4069           y(2)=0.0D0
4070           else
4071         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4072 #ifdef OSF
4073           phii=phi(i)
4074 c          icrc=0
4075 c          call proc_proc(phii,icrc)
4076           if (icrc.eq.1) phii=150.0
4077 #else
4078           phii=phi(i)
4079 #endif
4080           y(1)=dcos(phii)
4081           y(2)=dsin(phii)
4082         else
4083           y(1)=0.0D0
4084           y(2)=0.0D0
4085         endif
4086         endif
4087         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4088 #ifdef OSF
4089           phii1=phi(i+1)
4090 c          icrc=0
4091 c          call proc_proc(phii1,icrc)
4092           if (icrc.eq.1) phii1=150.0
4093           phii1=pinorm(phii1)
4094           z(1)=cos(phii1)
4095 #else
4096           phii1=phi(i+1)
4097           z(1)=dcos(phii1)
4098 #endif
4099           z(2)=dsin(phii1)
4100         else
4101           z(1)=0.0D0
4102           z(2)=0.0D0
4103         endif
4104 C Calculate the "mean" value of theta from the part of the distribution
4105 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4106 C In following comments this theta will be referred to as t_c.
4107         thet_pred_mean=0.0d0
4108         do k=1,2
4109             athetk=athet(k,it,ichir1,ichir2)
4110             bthetk=bthet(k,it,ichir1,ichir2)
4111           if (it.eq.10) then
4112              athetk=athet(k,itype1,ichir11,ichir12)
4113              bthetk=bthet(k,itype2,ichir21,ichir22)
4114           endif
4115           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4116         enddo
4117 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4118         dthett=thet_pred_mean*ssd
4119         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4120 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4121 C Derivatives of the "mean" values in gamma1 and gamma2.
4122         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4123      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4124          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4125      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4126          if (it.eq.10) then
4127       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4128      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4129         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4130      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4131          endif
4132         if (theta(i).gt.pi-delta) then
4133           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4134      &         E_tc0)
4135           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4136           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4137           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4138      &        E_theta)
4139           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4140      &        E_tc)
4141         else if (theta(i).lt.delta) then
4142           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4143           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4144           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4145      &        E_theta)
4146           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4147           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4148      &        E_tc)
4149         else
4150           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4151      &        E_theta,E_tc)
4152         endif
4153         etheta=etheta+ethetai
4154 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4155 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4156         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4157         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4158         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4159 c 1215   continue
4160       enddo
4161 C Ufff.... We've done all this!!!
4162 C now constrains
4163       ethetacnstr=0.0d0
4164 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4165       do i=1,ntheta_constr
4166         itheta=itheta_constr(i)
4167         thetiii=theta(itheta)
4168         difi=pinorm(thetiii-theta_constr0(i))
4169         if (difi.gt.theta_drange(i)) then
4170           difi=difi-theta_drange(i)
4171           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4172           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4173      &    +for_thet_constr(i)*difi**3
4174         else if (difi.lt.-drange(i)) then
4175           difi=difi+drange(i)
4176           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4177           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4178      &    +for_thet_constr(i)*difi**3
4179         else
4180           difi=0.0
4181         endif
4182 C       if (energy_dec) then
4183 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4184 C     &    i,itheta,rad2deg*thetiii,
4185 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4186 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4187 C     &    gloc(itheta+nphi-2,icg)
4188 C        endif
4189       enddo
4190       return
4191       end
4192 C---------------------------------------------------------------------------
4193       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4194      &     E_tc)
4195       implicit real*8 (a-h,o-z)
4196       include 'DIMENSIONS'
4197       include 'COMMON.LOCAL'
4198       include 'COMMON.IOUNITS'
4199       common /calcthet/ term1,term2,termm,diffak,ratak,
4200      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4201      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4202 C Calculate the contributions to both Gaussian lobes.
4203 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4204 C The "polynomial part" of the "standard deviation" of this part of
4205 C the distribution.
4206         sig=polthet(3,it)
4207         do j=2,0,-1
4208           sig=sig*thet_pred_mean+polthet(j,it)
4209         enddo
4210 C Derivative of the "interior part" of the "standard deviation of the"
4211 C gamma-dependent Gaussian lobe in t_c.
4212         sigtc=3*polthet(3,it)
4213         do j=2,1,-1
4214           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4215         enddo
4216         sigtc=sig*sigtc
4217 C Set the parameters of both Gaussian lobes of the distribution.
4218 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4219         fac=sig*sig+sigc0(it)
4220         sigcsq=fac+fac
4221         sigc=1.0D0/sigcsq
4222 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4223         sigsqtc=-4.0D0*sigcsq*sigtc
4224 c       print *,i,sig,sigtc,sigsqtc
4225 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4226         sigtc=-sigtc/(fac*fac)
4227 C Following variable is sigma(t_c)**(-2)
4228         sigcsq=sigcsq*sigcsq
4229         sig0i=sig0(it)
4230         sig0inv=1.0D0/sig0i**2
4231         delthec=thetai-thet_pred_mean
4232         delthe0=thetai-theta0i
4233         term1=-0.5D0*sigcsq*delthec*delthec
4234         term2=-0.5D0*sig0inv*delthe0*delthe0
4235 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4236 C NaNs in taking the logarithm. We extract the largest exponent which is added
4237 C to the energy (this being the log of the distribution) at the end of energy
4238 C term evaluation for this virtual-bond angle.
4239         if (term1.gt.term2) then
4240           termm=term1
4241           term2=dexp(term2-termm)
4242           term1=1.0d0
4243         else
4244           termm=term2
4245           term1=dexp(term1-termm)
4246           term2=1.0d0
4247         endif
4248 C The ratio between the gamma-independent and gamma-dependent lobes of
4249 C the distribution is a Gaussian function of thet_pred_mean too.
4250         diffak=gthet(2,it)-thet_pred_mean
4251         ratak=diffak/gthet(3,it)**2
4252         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4253 C Let's differentiate it in thet_pred_mean NOW.
4254         aktc=ak*ratak
4255 C Now put together the distribution terms to make complete distribution.
4256         termexp=term1+ak*term2
4257         termpre=sigc+ak*sig0i
4258 C Contribution of the bending energy from this theta is just the -log of
4259 C the sum of the contributions from the two lobes and the pre-exponential
4260 C factor. Simple enough, isn't it?
4261         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4262 C NOW the derivatives!!!
4263 C 6/6/97 Take into account the deformation.
4264         E_theta=(delthec*sigcsq*term1
4265      &       +ak*delthe0*sig0inv*term2)/termexp
4266         E_tc=((sigtc+aktc*sig0i)/termpre
4267      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4268      &       aktc*term2)/termexp)
4269       return
4270       end
4271 c-----------------------------------------------------------------------------
4272       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4273       implicit real*8 (a-h,o-z)
4274       include 'DIMENSIONS'
4275       include 'COMMON.LOCAL'
4276       include 'COMMON.IOUNITS'
4277       common /calcthet/ term1,term2,termm,diffak,ratak,
4278      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4279      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4280       delthec=thetai-thet_pred_mean
4281       delthe0=thetai-theta0i
4282 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4283       t3 = thetai-thet_pred_mean
4284       t6 = t3**2
4285       t9 = term1
4286       t12 = t3*sigcsq
4287       t14 = t12+t6*sigsqtc
4288       t16 = 1.0d0
4289       t21 = thetai-theta0i
4290       t23 = t21**2
4291       t26 = term2
4292       t27 = t21*t26
4293       t32 = termexp
4294       t40 = t32**2
4295       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4296      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4297      & *(-t12*t9-ak*sig0inv*t27)
4298       return
4299       end
4300 #else
4301 C--------------------------------------------------------------------------
4302       subroutine ebend(etheta,ethetacnstr)
4303 C
4304 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4305 C angles gamma and its derivatives in consecutive thetas and gammas.
4306 C ab initio-derived potentials from
4307 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4308 C
4309       implicit real*8 (a-h,o-z)
4310       include 'DIMENSIONS'
4311       include 'sizesclu.dat'
4312       include 'COMMON.LOCAL'
4313       include 'COMMON.GEO'
4314       include 'COMMON.INTERACT'
4315       include 'COMMON.DERIV'
4316       include 'COMMON.VAR'
4317       include 'COMMON.CHAIN'
4318       include 'COMMON.IOUNITS'
4319       include 'COMMON.NAMES'
4320       include 'COMMON.FFIELD'
4321       include 'COMMON.CONTROL'
4322       include 'COMMON.TORCNSTR'
4323       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4324      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4325      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4326      & sinph1ph2(maxdouble,maxdouble)
4327       logical lprn /.false./, lprn1 /.false./
4328       etheta=0.0D0
4329 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4330       do i=ithet_start,ithet_end
4331         if (i.le.2) cycle
4332         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4333      &  .or.itype(i).eq.ntyp1) cycle
4334 c        if (itype(i-1).eq.ntyp1) cycle
4335         if (iabs(itype(i+1)).eq.20) iblock=2
4336         if (iabs(itype(i+1)).ne.20) iblock=1
4337         dethetai=0.0d0
4338         dephii=0.0d0
4339         dephii1=0.0d0
4340         theti2=0.5d0*theta(i)
4341         ityp2=ithetyp((itype(i-1)))
4342         do k=1,nntheterm
4343           coskt(k)=dcos(k*theti2)
4344           sinkt(k)=dsin(k*theti2)
4345         enddo
4346         if (i.eq.3) then
4347           phii=0.0d0
4348           ityp1=nthetyp+1
4349           do k=1,nsingle
4350             cosph1(k)=0.0d0
4351             sinph1(k)=0.0d0
4352           enddo
4353         else
4354         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4355 #ifdef OSF
4356           phii=phi(i)
4357           if (phii.ne.phii) phii=150.0
4358 #else
4359           phii=phi(i)
4360 #endif
4361           ityp1=ithetyp((itype(i-2)))
4362           do k=1,nsingle
4363             cosph1(k)=dcos(k*phii)
4364             sinph1(k)=dsin(k*phii)
4365           enddo
4366         else
4367           phii=0.0d0
4368 c          ityp1=nthetyp+1
4369           do k=1,nsingle
4370             ityp1=ithetyp((itype(i-2)))
4371             cosph1(k)=0.0d0
4372             sinph1(k)=0.0d0
4373           enddo
4374         endif
4375         endif
4376         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4377 #ifdef OSF
4378           phii1=phi(i+1)
4379           if (phii1.ne.phii1) phii1=150.0
4380           phii1=pinorm(phii1)
4381 #else
4382           phii1=phi(i+1)
4383 #endif
4384           ityp3=ithetyp((itype(i)))
4385           do k=1,nsingle
4386             cosph2(k)=dcos(k*phii1)
4387             sinph2(k)=dsin(k*phii1)
4388           enddo
4389         else
4390           phii1=0.0d0
4391 c          ityp3=nthetyp+1
4392           ityp3=ithetyp((itype(i)))
4393           do k=1,nsingle
4394             cosph2(k)=0.0d0
4395             sinph2(k)=0.0d0
4396           enddo
4397         endif
4398 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4399 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4400 c        call flush(iout)
4401         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4402         do k=1,ndouble
4403           do l=1,k-1
4404             ccl=cosph1(l)*cosph2(k-l)
4405             ssl=sinph1(l)*sinph2(k-l)
4406             scl=sinph1(l)*cosph2(k-l)
4407             csl=cosph1(l)*sinph2(k-l)
4408             cosph1ph2(l,k)=ccl-ssl
4409             cosph1ph2(k,l)=ccl+ssl
4410             sinph1ph2(l,k)=scl+csl
4411             sinph1ph2(k,l)=scl-csl
4412           enddo
4413         enddo
4414         if (lprn) then
4415         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4416      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4417         write (iout,*) "coskt and sinkt"
4418         do k=1,nntheterm
4419           write (iout,*) k,coskt(k),sinkt(k)
4420         enddo
4421         endif
4422         do k=1,ntheterm
4423           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4424           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4425      &      *coskt(k)
4426           if (lprn)
4427      &    write (iout,*) "k",k," aathet",
4428      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4429      &     " ethetai",ethetai
4430         enddo
4431         if (lprn) then
4432         write (iout,*) "cosph and sinph"
4433         do k=1,nsingle
4434           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4435         enddo
4436         write (iout,*) "cosph1ph2 and sinph2ph2"
4437         do k=2,ndouble
4438           do l=1,k-1
4439             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4440      &         sinph1ph2(l,k),sinph1ph2(k,l)
4441           enddo
4442         enddo
4443         write(iout,*) "ethetai",ethetai
4444         endif
4445         do m=1,ntheterm2
4446           do k=1,nsingle
4447             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4448      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4449      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4450      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4451             ethetai=ethetai+sinkt(m)*aux
4452             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4453             dephii=dephii+k*sinkt(m)*(
4454      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4455      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4456             dephii1=dephii1+k*sinkt(m)*(
4457      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4458      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4459             if (lprn)
4460      &      write (iout,*) "m",m," k",k," bbthet",
4461      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4462      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4463      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4464      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4465           enddo
4466         enddo
4467         if (lprn)
4468      &  write(iout,*) "ethetai",ethetai
4469         do m=1,ntheterm3
4470           do k=2,ndouble
4471             do l=1,k-1
4472               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4473      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4474      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4475      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4476               ethetai=ethetai+sinkt(m)*aux
4477               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4478               dephii=dephii+l*sinkt(m)*(
4479      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4480      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4481      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4482      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4483               dephii1=dephii1+(k-l)*sinkt(m)*(
4484      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4485      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4486      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4487      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4488               if (lprn) then
4489               write (iout,*) "m",m," k",k," l",l," ffthet",
4490      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4491      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4492      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4493      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4494      &            " ethetai",ethetai
4495               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4496      &            cosph1ph2(k,l)*sinkt(m),
4497      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4498               endif
4499             enddo
4500           enddo
4501         enddo
4502 10      continue
4503         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4504      &   i,theta(i)*rad2deg,phii*rad2deg,
4505      &   phii1*rad2deg,ethetai
4506         etheta=etheta+ethetai
4507         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4508         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4509 c        gloc(nphi+i-2,icg)=wang*dethetai
4510         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4511       enddo
4512 C now constrains
4513       ethetacnstr=0.0d0
4514 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4515       do i=1,ntheta_constr
4516         itheta=itheta_constr(i)
4517         thetiii=theta(itheta)
4518         difi=pinorm(thetiii-theta_constr0(i))
4519         if (difi.gt.theta_drange(i)) then
4520           difi=difi-theta_drange(i)
4521           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4522           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4523      &    +for_thet_constr(i)*difi**3
4524         else if (difi.lt.-drange(i)) then
4525           difi=difi+drange(i)
4526           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4527           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4528      &    +for_thet_constr(i)*difi**3
4529         else
4530           difi=0.0
4531         endif
4532 C       if (energy_dec) then
4533 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4534 C     &    i,itheta,rad2deg*thetiii,
4535 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4536 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4537 C     &    gloc(itheta+nphi-2,icg)
4538 C        endif
4539       enddo
4540       return
4541       end
4542 #endif
4543 #ifdef CRYST_SC
4544 c-----------------------------------------------------------------------------
4545       subroutine esc(escloc)
4546 C Calculate the local energy of a side chain and its derivatives in the
4547 C corresponding virtual-bond valence angles THETA and the spherical angles
4548 C ALPHA and OMEGA.
4549       implicit real*8 (a-h,o-z)
4550       include 'DIMENSIONS'
4551       include 'sizesclu.dat'
4552       include 'COMMON.GEO'
4553       include 'COMMON.LOCAL'
4554       include 'COMMON.VAR'
4555       include 'COMMON.INTERACT'
4556       include 'COMMON.DERIV'
4557       include 'COMMON.CHAIN'
4558       include 'COMMON.IOUNITS'
4559       include 'COMMON.NAMES'
4560       include 'COMMON.FFIELD'
4561       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4562      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4563       common /sccalc/ time11,time12,time112,theti,it,nlobit
4564       delta=0.02d0*pi
4565       escloc=0.0D0
4566 c     write (iout,'(a)') 'ESC'
4567       do i=loc_start,loc_end
4568         it=itype(i)
4569         if (it.eq.ntyp1) cycle
4570         if (it.eq.10) goto 1
4571         nlobit=nlob(iabs(it))
4572 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4573 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4574         theti=theta(i+1)-pipol
4575         x(1)=dtan(theti)
4576         x(2)=alph(i)
4577         x(3)=omeg(i)
4578 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4579
4580         if (x(2).gt.pi-delta) then
4581           xtemp(1)=x(1)
4582           xtemp(2)=pi-delta
4583           xtemp(3)=x(3)
4584           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4585           xtemp(2)=pi
4586           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4587           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4588      &        escloci,dersc(2))
4589           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4590      &        ddersc0(1),dersc(1))
4591           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4592      &        ddersc0(3),dersc(3))
4593           xtemp(2)=pi-delta
4594           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4595           xtemp(2)=pi
4596           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4597           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4598      &            dersc0(2),esclocbi,dersc02)
4599           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4600      &            dersc12,dersc01)
4601           call splinthet(x(2),0.5d0*delta,ss,ssd)
4602           dersc0(1)=dersc01
4603           dersc0(2)=dersc02
4604           dersc0(3)=0.0d0
4605           do k=1,3
4606             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4607           enddo
4608           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4609 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4610 c    &             esclocbi,ss,ssd
4611           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4612 c         escloci=esclocbi
4613 c         write (iout,*) escloci
4614         else if (x(2).lt.delta) then
4615           xtemp(1)=x(1)
4616           xtemp(2)=delta
4617           xtemp(3)=x(3)
4618           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4619           xtemp(2)=0.0d0
4620           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4621           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4622      &        escloci,dersc(2))
4623           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4624      &        ddersc0(1),dersc(1))
4625           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4626      &        ddersc0(3),dersc(3))
4627           xtemp(2)=delta
4628           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4629           xtemp(2)=0.0d0
4630           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4631           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4632      &            dersc0(2),esclocbi,dersc02)
4633           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4634      &            dersc12,dersc01)
4635           dersc0(1)=dersc01
4636           dersc0(2)=dersc02
4637           dersc0(3)=0.0d0
4638           call splinthet(x(2),0.5d0*delta,ss,ssd)
4639           do k=1,3
4640             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4641           enddo
4642           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4643 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4644 c    &             esclocbi,ss,ssd
4645           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4646 c         write (iout,*) escloci
4647         else
4648           call enesc(x,escloci,dersc,ddummy,.false.)
4649         endif
4650
4651         escloc=escloc+escloci
4652 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4653
4654         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4655      &   wscloc*dersc(1)
4656         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4657         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4658     1   continue
4659       enddo
4660       return
4661       end
4662 C---------------------------------------------------------------------------
4663       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4664       implicit real*8 (a-h,o-z)
4665       include 'DIMENSIONS'
4666       include 'COMMON.GEO'
4667       include 'COMMON.LOCAL'
4668       include 'COMMON.IOUNITS'
4669       common /sccalc/ time11,time12,time112,theti,it,nlobit
4670       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4671       double precision contr(maxlob,-1:1)
4672       logical mixed
4673 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4674         escloc_i=0.0D0
4675         do j=1,3
4676           dersc(j)=0.0D0
4677           if (mixed) ddersc(j)=0.0d0
4678         enddo
4679         x3=x(3)
4680
4681 C Because of periodicity of the dependence of the SC energy in omega we have
4682 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4683 C To avoid underflows, first compute & store the exponents.
4684
4685         do iii=-1,1
4686
4687           x(3)=x3+iii*dwapi
4688
4689           do j=1,nlobit
4690             do k=1,3
4691               z(k)=x(k)-censc(k,j,it)
4692             enddo
4693             do k=1,3
4694               Axk=0.0D0
4695               do l=1,3
4696                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4697               enddo
4698               Ax(k,j,iii)=Axk
4699             enddo
4700             expfac=0.0D0
4701             do k=1,3
4702               expfac=expfac+Ax(k,j,iii)*z(k)
4703             enddo
4704             contr(j,iii)=expfac
4705           enddo ! j
4706
4707         enddo ! iii
4708
4709         x(3)=x3
4710 C As in the case of ebend, we want to avoid underflows in exponentiation and
4711 C subsequent NaNs and INFs in energy calculation.
4712 C Find the largest exponent
4713         emin=contr(1,-1)
4714         do iii=-1,1
4715           do j=1,nlobit
4716             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4717           enddo
4718         enddo
4719         emin=0.5D0*emin
4720 cd      print *,'it=',it,' emin=',emin
4721
4722 C Compute the contribution to SC energy and derivatives
4723         do iii=-1,1
4724
4725           do j=1,nlobit
4726             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4727 cd          print *,'j=',j,' expfac=',expfac
4728             escloc_i=escloc_i+expfac
4729             do k=1,3
4730               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4731             enddo
4732             if (mixed) then
4733               do k=1,3,2
4734                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4735      &            +gaussc(k,2,j,it))*expfac
4736               enddo
4737             endif
4738           enddo
4739
4740         enddo ! iii
4741
4742         dersc(1)=dersc(1)/cos(theti)**2
4743         ddersc(1)=ddersc(1)/cos(theti)**2
4744         ddersc(3)=ddersc(3)
4745
4746         escloci=-(dlog(escloc_i)-emin)
4747         do j=1,3
4748           dersc(j)=dersc(j)/escloc_i
4749         enddo
4750         if (mixed) then
4751           do j=1,3,2
4752             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4753           enddo
4754         endif
4755       return
4756       end
4757 C------------------------------------------------------------------------------
4758       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4759       implicit real*8 (a-h,o-z)
4760       include 'DIMENSIONS'
4761       include 'COMMON.GEO'
4762       include 'COMMON.LOCAL'
4763       include 'COMMON.IOUNITS'
4764       common /sccalc/ time11,time12,time112,theti,it,nlobit
4765       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4766       double precision contr(maxlob)
4767       logical mixed
4768
4769       escloc_i=0.0D0
4770
4771       do j=1,3
4772         dersc(j)=0.0D0
4773       enddo
4774
4775       do j=1,nlobit
4776         do k=1,2
4777           z(k)=x(k)-censc(k,j,it)
4778         enddo
4779         z(3)=dwapi
4780         do k=1,3
4781           Axk=0.0D0
4782           do l=1,3
4783             Axk=Axk+gaussc(l,k,j,it)*z(l)
4784           enddo
4785           Ax(k,j)=Axk
4786         enddo
4787         expfac=0.0D0
4788         do k=1,3
4789           expfac=expfac+Ax(k,j)*z(k)
4790         enddo
4791         contr(j)=expfac
4792       enddo ! j
4793
4794 C As in the case of ebend, we want to avoid underflows in exponentiation and
4795 C subsequent NaNs and INFs in energy calculation.
4796 C Find the largest exponent
4797       emin=contr(1)
4798       do j=1,nlobit
4799         if (emin.gt.contr(j)) emin=contr(j)
4800       enddo
4801       emin=0.5D0*emin
4802
4803 C Compute the contribution to SC energy and derivatives
4804
4805       dersc12=0.0d0
4806       do j=1,nlobit
4807         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4808         escloc_i=escloc_i+expfac
4809         do k=1,2
4810           dersc(k)=dersc(k)+Ax(k,j)*expfac
4811         enddo
4812         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4813      &            +gaussc(1,2,j,it))*expfac
4814         dersc(3)=0.0d0
4815       enddo
4816
4817       dersc(1)=dersc(1)/cos(theti)**2
4818       dersc12=dersc12/cos(theti)**2
4819       escloci=-(dlog(escloc_i)-emin)
4820       do j=1,2
4821         dersc(j)=dersc(j)/escloc_i
4822       enddo
4823       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4824       return
4825       end
4826 #else
4827 c----------------------------------------------------------------------------------
4828       subroutine esc(escloc)
4829 C Calculate the local energy of a side chain and its derivatives in the
4830 C corresponding virtual-bond valence angles THETA and the spherical angles
4831 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4832 C added by Urszula Kozlowska. 07/11/2007
4833 C
4834       implicit real*8 (a-h,o-z)
4835       include 'DIMENSIONS'
4836       include 'sizesclu.dat'
4837       include 'COMMON.GEO'
4838       include 'COMMON.LOCAL'
4839       include 'COMMON.VAR'
4840       include 'COMMON.SCROT'
4841       include 'COMMON.INTERACT'
4842       include 'COMMON.DERIV'
4843       include 'COMMON.CHAIN'
4844       include 'COMMON.IOUNITS'
4845       include 'COMMON.NAMES'
4846       include 'COMMON.FFIELD'
4847       include 'COMMON.CONTROL'
4848       include 'COMMON.VECTORS'
4849       double precision x_prime(3),y_prime(3),z_prime(3)
4850      &    , sumene,dsc_i,dp2_i,x(65),
4851      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4852      &    de_dxx,de_dyy,de_dzz,de_dt
4853       double precision s1_t,s1_6_t,s2_t,s2_6_t
4854       double precision
4855      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4856      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4857      & dt_dCi(3),dt_dCi1(3)
4858       common /sccalc/ time11,time12,time112,theti,it,nlobit
4859       delta=0.02d0*pi
4860       escloc=0.0D0
4861       do i=loc_start,loc_end
4862         if (itype(i).eq.ntyp1) cycle
4863         costtab(i+1) =dcos(theta(i+1))
4864         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4865         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4866         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4867         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4868         cosfac=dsqrt(cosfac2)
4869         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4870         sinfac=dsqrt(sinfac2)
4871         it=iabs(itype(i))
4872         if (it.eq.10) goto 1
4873 c
4874 C  Compute the axes of tghe local cartesian coordinates system; store in
4875 c   x_prime, y_prime and z_prime
4876 c
4877         do j=1,3
4878           x_prime(j) = 0.00
4879           y_prime(j) = 0.00
4880           z_prime(j) = 0.00
4881         enddo
4882 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4883 C     &   dc_norm(3,i+nres)
4884         do j = 1,3
4885           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4886           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4887         enddo
4888         do j = 1,3
4889           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4890         enddo
4891 c       write (2,*) "i",i
4892 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4893 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4894 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4895 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4896 c      & " xy",scalar(x_prime(1),y_prime(1)),
4897 c      & " xz",scalar(x_prime(1),z_prime(1)),
4898 c      & " yy",scalar(y_prime(1),y_prime(1)),
4899 c      & " yz",scalar(y_prime(1),z_prime(1)),
4900 c      & " zz",scalar(z_prime(1),z_prime(1))
4901 c
4902 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4903 C to local coordinate system. Store in xx, yy, zz.
4904 c
4905         xx=0.0d0
4906         yy=0.0d0
4907         zz=0.0d0
4908         do j = 1,3
4909           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4910           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4911           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4912         enddo
4913
4914         xxtab(i)=xx
4915         yytab(i)=yy
4916         zztab(i)=zz
4917 C
4918 C Compute the energy of the ith side cbain
4919 C
4920 c        write (2,*) "xx",xx," yy",yy," zz",zz
4921         it=iabs(itype(i))
4922         do j = 1,65
4923           x(j) = sc_parmin(j,it)
4924         enddo
4925 #ifdef CHECK_COORD
4926 Cc diagnostics - remove later
4927         xx1 = dcos(alph(2))
4928         yy1 = dsin(alph(2))*dcos(omeg(2))
4929 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4930         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4931         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4932      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4933      &    xx1,yy1,zz1
4934 C,"  --- ", xx_w,yy_w,zz_w
4935 c end diagnostics
4936 #endif
4937         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4938      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4939      &   + x(10)*yy*zz
4940         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4941      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4942      & + x(20)*yy*zz
4943         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4944      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4945      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4946      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4947      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4948      &  +x(40)*xx*yy*zz
4949         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4950      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4951      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4952      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4953      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4954      &  +x(60)*xx*yy*zz
4955         dsc_i   = 0.743d0+x(61)
4956         dp2_i   = 1.9d0+x(62)
4957         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4958      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4959         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4960      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4961         s1=(1+x(63))/(0.1d0 + dscp1)
4962         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4963         s2=(1+x(65))/(0.1d0 + dscp2)
4964         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4965         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4966      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4967 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4968 c     &   sumene4,
4969 c     &   dscp1,dscp2,sumene
4970 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4971         escloc = escloc + sumene
4972 c        write (2,*) "escloc",escloc
4973         if (.not. calc_grad) goto 1
4974 #ifdef DEBUG
4975 C
4976 C This section to check the numerical derivatives of the energy of ith side
4977 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4978 C #define DEBUG in the code to turn it on.
4979 C
4980         write (2,*) "sumene               =",sumene
4981         aincr=1.0d-7
4982         xxsave=xx
4983         xx=xx+aincr
4984         write (2,*) xx,yy,zz
4985         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4986         de_dxx_num=(sumenep-sumene)/aincr
4987         xx=xxsave
4988         write (2,*) "xx+ sumene from enesc=",sumenep
4989         yysave=yy
4990         yy=yy+aincr
4991         write (2,*) xx,yy,zz
4992         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4993         de_dyy_num=(sumenep-sumene)/aincr
4994         yy=yysave
4995         write (2,*) "yy+ sumene from enesc=",sumenep
4996         zzsave=zz
4997         zz=zz+aincr
4998         write (2,*) xx,yy,zz
4999         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5000         de_dzz_num=(sumenep-sumene)/aincr
5001         zz=zzsave
5002         write (2,*) "zz+ sumene from enesc=",sumenep
5003         costsave=cost2tab(i+1)
5004         sintsave=sint2tab(i+1)
5005         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5006         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5007         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5008         de_dt_num=(sumenep-sumene)/aincr
5009         write (2,*) " t+ sumene from enesc=",sumenep
5010         cost2tab(i+1)=costsave
5011         sint2tab(i+1)=sintsave
5012 C End of diagnostics section.
5013 #endif
5014 C
5015 C Compute the gradient of esc
5016 C
5017         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5018         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5019         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5020         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5021         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5022         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5023         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5024         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5025         pom1=(sumene3*sint2tab(i+1)+sumene1)
5026      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5027         pom2=(sumene4*cost2tab(i+1)+sumene2)
5028      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5029         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5030         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5031      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5032      &  +x(40)*yy*zz
5033         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5034         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5035      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5036      &  +x(60)*yy*zz
5037         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5038      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5039      &        +(pom1+pom2)*pom_dx
5040 #ifdef DEBUG
5041         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5042 #endif
5043 C
5044         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5045         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5046      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5047      &  +x(40)*xx*zz
5048         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5049         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5050      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5051      &  +x(59)*zz**2 +x(60)*xx*zz
5052         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5053      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5054      &        +(pom1-pom2)*pom_dy
5055 #ifdef DEBUG
5056         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5057 #endif
5058 C
5059         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5060      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5061      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5062      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5063      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5064      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5065      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5066      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5067 #ifdef DEBUG
5068         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5069 #endif
5070 C
5071         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5072      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5073      &  +pom1*pom_dt1+pom2*pom_dt2
5074 #ifdef DEBUG
5075         write(2,*), "de_dt = ", de_dt,de_dt_num
5076 #endif
5077 c
5078 C
5079        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5080        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5081        cosfac2xx=cosfac2*xx
5082        sinfac2yy=sinfac2*yy
5083        do k = 1,3
5084          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5085      &      vbld_inv(i+1)
5086          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5087      &      vbld_inv(i)
5088          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5089          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5090 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5091 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5092 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5093 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5094          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5095          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5096          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5097          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5098          dZZ_Ci1(k)=0.0d0
5099          dZZ_Ci(k)=0.0d0
5100          do j=1,3
5101            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5102      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5103            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5104      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5105          enddo
5106
5107          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5108          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5109          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5110 c
5111          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5112          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5113        enddo
5114
5115        do k=1,3
5116          dXX_Ctab(k,i)=dXX_Ci(k)
5117          dXX_C1tab(k,i)=dXX_Ci1(k)
5118          dYY_Ctab(k,i)=dYY_Ci(k)
5119          dYY_C1tab(k,i)=dYY_Ci1(k)
5120          dZZ_Ctab(k,i)=dZZ_Ci(k)
5121          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5122          dXX_XYZtab(k,i)=dXX_XYZ(k)
5123          dYY_XYZtab(k,i)=dYY_XYZ(k)
5124          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5125        enddo
5126
5127        do k = 1,3
5128 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5129 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5130 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5131 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5132 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5133 c     &    dt_dci(k)
5134 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5135 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5136          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5137      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5138          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5139      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5140          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5141      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5142        enddo
5143 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5144 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5145
5146 C to check gradient call subroutine check_grad
5147
5148     1 continue
5149       enddo
5150       return
5151       end
5152 #endif
5153 c------------------------------------------------------------------------------
5154       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5155 C
5156 C This procedure calculates two-body contact function g(rij) and its derivative:
5157 C
5158 C           eps0ij                                     !       x < -1
5159 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5160 C            0                                         !       x > 1
5161 C
5162 C where x=(rij-r0ij)/delta
5163 C
5164 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5165 C
5166       implicit none
5167       double precision rij,r0ij,eps0ij,fcont,fprimcont
5168       double precision x,x2,x4,delta
5169 c     delta=0.02D0*r0ij
5170 c      delta=0.2D0*r0ij
5171       x=(rij-r0ij)/delta
5172       if (x.lt.-1.0D0) then
5173         fcont=eps0ij
5174         fprimcont=0.0D0
5175       else if (x.le.1.0D0) then
5176         x2=x*x
5177         x4=x2*x2
5178         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5179         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5180       else
5181         fcont=0.0D0
5182         fprimcont=0.0D0
5183       endif
5184       return
5185       end
5186 c------------------------------------------------------------------------------
5187       subroutine splinthet(theti,delta,ss,ssder)
5188       implicit real*8 (a-h,o-z)
5189       include 'DIMENSIONS'
5190       include 'sizesclu.dat'
5191       include 'COMMON.VAR'
5192       include 'COMMON.GEO'
5193       thetup=pi-delta
5194       thetlow=delta
5195       if (theti.gt.pipol) then
5196         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5197       else
5198         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5199         ssder=-ssder
5200       endif
5201       return
5202       end
5203 c------------------------------------------------------------------------------
5204       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5205       implicit none
5206       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5207       double precision ksi,ksi2,ksi3,a1,a2,a3
5208       a1=fprim0*delta/(f1-f0)
5209       a2=3.0d0-2.0d0*a1
5210       a3=a1-2.0d0
5211       ksi=(x-x0)/delta
5212       ksi2=ksi*ksi
5213       ksi3=ksi2*ksi
5214       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5215       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5216       return
5217       end
5218 c------------------------------------------------------------------------------
5219       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5220       implicit none
5221       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5222       double precision ksi,ksi2,ksi3,a1,a2,a3
5223       ksi=(x-x0)/delta
5224       ksi2=ksi*ksi
5225       ksi3=ksi2*ksi
5226       a1=fprim0x*delta
5227       a2=3*(f1x-f0x)-2*fprim0x*delta
5228       a3=fprim0x*delta-2*(f1x-f0x)
5229       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5230       return
5231       end
5232 C-----------------------------------------------------------------------------
5233 #ifdef CRYST_TOR
5234 C-----------------------------------------------------------------------------
5235       subroutine etor(etors,edihcnstr,fact)
5236       implicit real*8 (a-h,o-z)
5237       include 'DIMENSIONS'
5238       include 'sizesclu.dat'
5239       include 'COMMON.VAR'
5240       include 'COMMON.GEO'
5241       include 'COMMON.LOCAL'
5242       include 'COMMON.TORSION'
5243       include 'COMMON.INTERACT'
5244       include 'COMMON.DERIV'
5245       include 'COMMON.CHAIN'
5246       include 'COMMON.NAMES'
5247       include 'COMMON.IOUNITS'
5248       include 'COMMON.FFIELD'
5249       include 'COMMON.TORCNSTR'
5250       logical lprn
5251 C Set lprn=.true. for debugging
5252       lprn=.false.
5253 c      lprn=.true.
5254       etors=0.0D0
5255       do i=iphi_start,iphi_end
5256         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5257      &      .or. itype(i).eq.ntyp1) cycle
5258         itori=itortyp(itype(i-2))
5259         itori1=itortyp(itype(i-1))
5260         phii=phi(i)
5261         gloci=0.0D0
5262 C Proline-Proline pair is a special case...
5263         if (itori.eq.3 .and. itori1.eq.3) then
5264           if (phii.gt.-dwapi3) then
5265             cosphi=dcos(3*phii)
5266             fac=1.0D0/(1.0D0-cosphi)
5267             etorsi=v1(1,3,3)*fac
5268             etorsi=etorsi+etorsi
5269             etors=etors+etorsi-v1(1,3,3)
5270             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5271           endif
5272           do j=1,3
5273             v1ij=v1(j+1,itori,itori1)
5274             v2ij=v2(j+1,itori,itori1)
5275             cosphi=dcos(j*phii)
5276             sinphi=dsin(j*phii)
5277             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5278             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5279           enddo
5280         else
5281           do j=1,nterm_old
5282             v1ij=v1(j,itori,itori1)
5283             v2ij=v2(j,itori,itori1)
5284             cosphi=dcos(j*phii)
5285             sinphi=dsin(j*phii)
5286             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5287             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5288           enddo
5289         endif
5290         if (lprn)
5291      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5292      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5293      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5294         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5295 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5296       enddo
5297 ! 6/20/98 - dihedral angle constraints
5298       edihcnstr=0.0d0
5299       do i=1,ndih_constr
5300         itori=idih_constr(i)
5301         phii=phi(itori)
5302         difi=phii-phi0(i)
5303         if (difi.gt.drange(i)) then
5304           difi=difi-drange(i)
5305           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5306           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5307         else if (difi.lt.-drange(i)) then
5308           difi=difi+drange(i)
5309           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5310           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5311         endif
5312 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5313 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5314       enddo
5315 !      write (iout,*) 'edihcnstr',edihcnstr
5316       return
5317       end
5318 c------------------------------------------------------------------------------
5319 #else
5320       subroutine etor(etors,edihcnstr,fact)
5321       implicit real*8 (a-h,o-z)
5322       include 'DIMENSIONS'
5323       include 'sizesclu.dat'
5324       include 'COMMON.VAR'
5325       include 'COMMON.GEO'
5326       include 'COMMON.LOCAL'
5327       include 'COMMON.TORSION'
5328       include 'COMMON.INTERACT'
5329       include 'COMMON.DERIV'
5330       include 'COMMON.CHAIN'
5331       include 'COMMON.NAMES'
5332       include 'COMMON.IOUNITS'
5333       include 'COMMON.FFIELD'
5334       include 'COMMON.TORCNSTR'
5335       logical lprn
5336 C Set lprn=.true. for debugging
5337       lprn=.false.
5338 c      lprn=.true.
5339       etors=0.0D0
5340       do i=iphi_start,iphi_end
5341         if (i.le.2) cycle
5342         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5343      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5344         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5345          if (iabs(itype(i)).eq.20) then
5346          iblock=2
5347          else
5348          iblock=1
5349          endif
5350         itori=itortyp(itype(i-2))
5351         itori1=itortyp(itype(i-1))
5352         phii=phi(i)
5353         gloci=0.0D0
5354 C Regular cosine and sine terms
5355         do j=1,nterm(itori,itori1,iblock)
5356           v1ij=v1(j,itori,itori1,iblock)
5357           v2ij=v2(j,itori,itori1,iblock)
5358           cosphi=dcos(j*phii)
5359           sinphi=dsin(j*phii)
5360           etors=etors+v1ij*cosphi+v2ij*sinphi
5361           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5362         enddo
5363 C Lorentz terms
5364 C                         v1
5365 C  E = SUM ----------------------------------- - v1
5366 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5367 C
5368         cosphi=dcos(0.5d0*phii)
5369         sinphi=dsin(0.5d0*phii)
5370         do j=1,nlor(itori,itori1,iblock)
5371           vl1ij=vlor1(j,itori,itori1)
5372           vl2ij=vlor2(j,itori,itori1)
5373           vl3ij=vlor3(j,itori,itori1)
5374           pom=vl2ij*cosphi+vl3ij*sinphi
5375           pom1=1.0d0/(pom*pom+1.0d0)
5376           etors=etors+vl1ij*pom1
5377           pom=-pom*pom1*pom1
5378           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5379         enddo
5380 C Subtract the constant term
5381         etors=etors-v0(itori,itori1,iblock)
5382         if (lprn)
5383      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5384      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5385      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5386         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5387 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5388  1215   continue
5389       enddo
5390 ! 6/20/98 - dihedral angle constraints
5391       edihcnstr=0.0d0
5392       do i=1,ndih_constr
5393         itori=idih_constr(i)
5394         phii=phi(itori)
5395         difi=pinorm(phii-phi0(i))
5396         edihi=0.0d0
5397         if (difi.gt.drange(i)) then
5398           difi=difi-drange(i)
5399           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5400           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5401           edihi=0.25d0*ftors(i)*difi**4
5402         else if (difi.lt.-drange(i)) then
5403           difi=difi+drange(i)
5404           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5405           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5406           edihi=0.25d0*ftors(i)*difi**4
5407         else
5408           difi=0.0d0
5409         endif
5410 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5411 c     &    drange(i),edihi
5412 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5413 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5414       enddo
5415 !      write (iout,*) 'edihcnstr',edihcnstr
5416       return
5417       end
5418 c----------------------------------------------------------------------------
5419       subroutine etor_d(etors_d,fact2)
5420 C 6/23/01 Compute double torsional energy
5421       implicit real*8 (a-h,o-z)
5422       include 'DIMENSIONS'
5423       include 'sizesclu.dat'
5424       include 'COMMON.VAR'
5425       include 'COMMON.GEO'
5426       include 'COMMON.LOCAL'
5427       include 'COMMON.TORSION'
5428       include 'COMMON.INTERACT'
5429       include 'COMMON.DERIV'
5430       include 'COMMON.CHAIN'
5431       include 'COMMON.NAMES'
5432       include 'COMMON.IOUNITS'
5433       include 'COMMON.FFIELD'
5434       include 'COMMON.TORCNSTR'
5435       logical lprn
5436 C Set lprn=.true. for debugging
5437       lprn=.false.
5438 c     lprn=.true.
5439       etors_d=0.0D0
5440       do i=iphi_start,iphi_end-1
5441         if (i.le.3) cycle
5442          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5443      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5444      &  (itype(i+1).eq.ntyp1)) cycle
5445         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5446      &     goto 1215
5447         itori=itortyp(itype(i-2))
5448         itori1=itortyp(itype(i-1))
5449         itori2=itortyp(itype(i))
5450         phii=phi(i)
5451         phii1=phi(i+1)
5452         gloci1=0.0D0
5453         gloci2=0.0D0
5454         iblock=1
5455         if (iabs(itype(i+1)).eq.20) iblock=2
5456 C Regular cosine and sine terms
5457        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5458           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5459           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5460           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5461           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5462           cosphi1=dcos(j*phii)
5463           sinphi1=dsin(j*phii)
5464           cosphi2=dcos(j*phii1)
5465           sinphi2=dsin(j*phii1)
5466           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5467      &     v2cij*cosphi2+v2sij*sinphi2
5468           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5469           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5470         enddo
5471         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5472           do l=1,k-1
5473             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5474             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5475             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5476             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5477             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5478             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5479             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5480             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5481             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5482      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5483             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5484      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5485             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5486      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5487           enddo
5488         enddo
5489         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5490         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5491  1215   continue
5492       enddo
5493       return
5494       end
5495 #endif
5496 c------------------------------------------------------------------------------
5497       subroutine eback_sc_corr(esccor)
5498 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5499 c        conformational states; temporarily implemented as differences
5500 c        between UNRES torsional potentials (dependent on three types of
5501 c        residues) and the torsional potentials dependent on all 20 types
5502 c        of residues computed from AM1 energy surfaces of terminally-blocked
5503 c        amino-acid residues.
5504       implicit real*8 (a-h,o-z)
5505       include 'DIMENSIONS'
5506       include 'sizesclu.dat'
5507       include 'COMMON.VAR'
5508       include 'COMMON.GEO'
5509       include 'COMMON.LOCAL'
5510       include 'COMMON.TORSION'
5511       include 'COMMON.SCCOR'
5512       include 'COMMON.INTERACT'
5513       include 'COMMON.DERIV'
5514       include 'COMMON.CHAIN'
5515       include 'COMMON.NAMES'
5516       include 'COMMON.IOUNITS'
5517       include 'COMMON.FFIELD'
5518       include 'COMMON.CONTROL'
5519       logical lprn
5520 C Set lprn=.true. for debugging
5521       lprn=.false.
5522 c      lprn=.true.
5523 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5524       esccor=0.0D0
5525       do i=itau_start,itau_end
5526         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5527         esccor_ii=0.0D0
5528         isccori=isccortyp(itype(i-2))
5529         isccori1=isccortyp(itype(i-1))
5530         phii=phi(i)
5531         do intertyp=1,3 !intertyp
5532 cc Added 09 May 2012 (Adasko)
5533 cc  Intertyp means interaction type of backbone mainchain correlation:
5534 c   1 = SC...Ca...Ca...Ca
5535 c   2 = Ca...Ca...Ca...SC
5536 c   3 = SC...Ca...Ca...SCi
5537         gloci=0.0D0
5538         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5539      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5540      &      (itype(i-1).eq.ntyp1)))
5541      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5542      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5543      &     .or.(itype(i).eq.ntyp1)))
5544      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5545      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5546      &      (itype(i-3).eq.ntyp1)))) cycle
5547         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5548         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5549      & cycle
5550        do j=1,nterm_sccor(isccori,isccori1)
5551           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5552           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5553           cosphi=dcos(j*tauangle(intertyp,i))
5554           sinphi=dsin(j*tauangle(intertyp,i))
5555            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5556 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5557          enddo
5558 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5559 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5560         if (lprn)
5561      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5562      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5563      &  (v1sccor(j,1,itori,itori1),j=1,6),
5564      &  (v2sccor(j,1,itori,itori1),j=1,6)
5565         gsccor_loc(i-3)=gloci
5566        enddo !intertyp
5567       enddo
5568       return
5569       end
5570 c------------------------------------------------------------------------------
5571       subroutine multibody(ecorr)
5572 C This subroutine calculates multi-body contributions to energy following
5573 C the idea of Skolnick et al. If side chains I and J make a contact and
5574 C at the same time side chains I+1 and J+1 make a contact, an extra
5575 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5576       implicit real*8 (a-h,o-z)
5577       include 'DIMENSIONS'
5578       include 'COMMON.IOUNITS'
5579       include 'COMMON.DERIV'
5580       include 'COMMON.INTERACT'
5581       include 'COMMON.CONTACTS'
5582       double precision gx(3),gx1(3)
5583       logical lprn
5584
5585 C Set lprn=.true. for debugging
5586       lprn=.false.
5587
5588       if (lprn) then
5589         write (iout,'(a)') 'Contact function values:'
5590         do i=nnt,nct-2
5591           write (iout,'(i2,20(1x,i2,f10.5))')
5592      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5593         enddo
5594       endif
5595       ecorr=0.0D0
5596       do i=nnt,nct
5597         do j=1,3
5598           gradcorr(j,i)=0.0D0
5599           gradxorr(j,i)=0.0D0
5600         enddo
5601       enddo
5602       do i=nnt,nct-2
5603
5604         DO ISHIFT = 3,4
5605
5606         i1=i+ishift
5607         num_conti=num_cont(i)
5608         num_conti1=num_cont(i1)
5609         do jj=1,num_conti
5610           j=jcont(jj,i)
5611           do kk=1,num_conti1
5612             j1=jcont(kk,i1)
5613             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5614 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5615 cd   &                   ' ishift=',ishift
5616 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5617 C The system gains extra energy.
5618               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5619             endif   ! j1==j+-ishift
5620           enddo     ! kk
5621         enddo       ! jj
5622
5623         ENDDO ! ISHIFT
5624
5625       enddo         ! i
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       double precision function esccorr(i,j,k,l,jj,kk)
5630       implicit real*8 (a-h,o-z)
5631       include 'DIMENSIONS'
5632       include 'COMMON.IOUNITS'
5633       include 'COMMON.DERIV'
5634       include 'COMMON.INTERACT'
5635       include 'COMMON.CONTACTS'
5636       double precision gx(3),gx1(3)
5637       logical lprn
5638       lprn=.false.
5639       eij=facont(jj,i)
5640       ekl=facont(kk,k)
5641 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5642 C Calculate the multi-body contribution to energy.
5643 C Calculate multi-body contributions to the gradient.
5644 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5645 cd   & k,l,(gacont(m,kk,k),m=1,3)
5646       do m=1,3
5647         gx(m) =ekl*gacont(m,jj,i)
5648         gx1(m)=eij*gacont(m,kk,k)
5649         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5650         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5651         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5652         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5653       enddo
5654       do m=i,j-1
5655         do ll=1,3
5656           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5657         enddo
5658       enddo
5659       do m=k,l-1
5660         do ll=1,3
5661           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5662         enddo
5663       enddo
5664       esccorr=-eij*ekl
5665       return
5666       end
5667 c------------------------------------------------------------------------------
5668 #ifdef MPL
5669       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5670       implicit real*8 (a-h,o-z)
5671       include 'DIMENSIONS'
5672       integer dimen1,dimen2,atom,indx
5673       double precision buffer(dimen1,dimen2)
5674       double precision zapas
5675       common /contacts_hb/ zapas(3,20,maxres,7),
5676      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5677      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5678       num_kont=num_cont_hb(atom)
5679       do i=1,num_kont
5680         do k=1,7
5681           do j=1,3
5682             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5683           enddo ! j
5684         enddo ! k
5685         buffer(i,indx+22)=facont_hb(i,atom)
5686         buffer(i,indx+23)=ees0p(i,atom)
5687         buffer(i,indx+24)=ees0m(i,atom)
5688         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5689       enddo ! i
5690       buffer(1,indx+26)=dfloat(num_kont)
5691       return
5692       end
5693 c------------------------------------------------------------------------------
5694       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5695       implicit real*8 (a-h,o-z)
5696       include 'DIMENSIONS'
5697       integer dimen1,dimen2,atom,indx
5698       double precision buffer(dimen1,dimen2)
5699       double precision zapas
5700       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5701      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5702      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5703       num_kont=buffer(1,indx+26)
5704       num_kont_old=num_cont_hb(atom)
5705       num_cont_hb(atom)=num_kont+num_kont_old
5706       do i=1,num_kont
5707         ii=i+num_kont_old
5708         do k=1,7
5709           do j=1,3
5710             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5711           enddo ! j
5712         enddo ! k
5713         facont_hb(ii,atom)=buffer(i,indx+22)
5714         ees0p(ii,atom)=buffer(i,indx+23)
5715         ees0m(ii,atom)=buffer(i,indx+24)
5716         jcont_hb(ii,atom)=buffer(i,indx+25)
5717       enddo ! i
5718       return
5719       end
5720 c------------------------------------------------------------------------------
5721 #endif
5722       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5723 C This subroutine calculates multi-body contributions to hydrogen-bonding
5724       implicit real*8 (a-h,o-z)
5725       include 'DIMENSIONS'
5726       include 'sizesclu.dat'
5727       include 'COMMON.IOUNITS'
5728 #ifdef MPL
5729       include 'COMMON.INFO'
5730 #endif
5731       include 'COMMON.FFIELD'
5732       include 'COMMON.DERIV'
5733       include 'COMMON.INTERACT'
5734       include 'COMMON.CONTACTS'
5735 #ifdef MPL
5736       parameter (max_cont=maxconts)
5737       parameter (max_dim=2*(8*3+2))
5738       parameter (msglen1=max_cont*max_dim*4)
5739       parameter (msglen2=2*msglen1)
5740       integer source,CorrelType,CorrelID,Error
5741       double precision buffer(max_cont,max_dim)
5742 #endif
5743       double precision gx(3),gx1(3)
5744       logical lprn,ldone
5745
5746 C Set lprn=.true. for debugging
5747       lprn=.false.
5748 #ifdef MPL
5749       n_corr=0
5750       n_corr1=0
5751       if (fgProcs.le.1) goto 30
5752       if (lprn) then
5753         write (iout,'(a)') 'Contact function values:'
5754         do i=nnt,nct-2
5755           write (iout,'(2i3,50(1x,i2,f5.2))')
5756      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5757      &    j=1,num_cont_hb(i))
5758         enddo
5759       endif
5760 C Caution! Following code assumes that electrostatic interactions concerning
5761 C a given atom are split among at most two processors!
5762       CorrelType=477
5763       CorrelID=MyID+1
5764       ldone=.false.
5765       do i=1,max_cont
5766         do j=1,max_dim
5767           buffer(i,j)=0.0D0
5768         enddo
5769       enddo
5770       mm=mod(MyRank,2)
5771 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5772       if (mm) 20,20,10
5773    10 continue
5774 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5775       if (MyRank.gt.0) then
5776 C Send correlation contributions to the preceding processor
5777         msglen=msglen1
5778         nn=num_cont_hb(iatel_s)
5779         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5780 cd      write (iout,*) 'The BUFFER array:'
5781 cd      do i=1,nn
5782 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5783 cd      enddo
5784         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5785           msglen=msglen2
5786             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5787 C Clear the contacts of the atom passed to the neighboring processor
5788         nn=num_cont_hb(iatel_s+1)
5789 cd      do i=1,nn
5790 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5791 cd      enddo
5792             num_cont_hb(iatel_s)=0
5793         endif
5794 cd      write (iout,*) 'Processor ',MyID,MyRank,
5795 cd   & ' is sending correlation contribution to processor',MyID-1,
5796 cd   & ' msglen=',msglen
5797 cd      write (*,*) 'Processor ',MyID,MyRank,
5798 cd   & ' is sending correlation contribution to processor',MyID-1,
5799 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5800         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5801 cd      write (iout,*) 'Processor ',MyID,
5802 cd   & ' has sent correlation contribution to processor',MyID-1,
5803 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5804 cd      write (*,*) 'Processor ',MyID,
5805 cd   & ' has sent correlation contribution to processor',MyID-1,
5806 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5807         msglen=msglen1
5808       endif ! (MyRank.gt.0)
5809       if (ldone) goto 30
5810       ldone=.true.
5811    20 continue
5812 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5813       if (MyRank.lt.fgProcs-1) then
5814 C Receive correlation contributions from the next processor
5815         msglen=msglen1
5816         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5817 cd      write (iout,*) 'Processor',MyID,
5818 cd   & ' is receiving correlation contribution from processor',MyID+1,
5819 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5820 cd      write (*,*) 'Processor',MyID,
5821 cd   & ' is receiving correlation contribution from processor',MyID+1,
5822 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5823         nbytes=-1
5824         do while (nbytes.le.0)
5825           call mp_probe(MyID+1,CorrelType,nbytes)
5826         enddo
5827 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5828         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5829 cd      write (iout,*) 'Processor',MyID,
5830 cd   & ' has received correlation contribution from processor',MyID+1,
5831 cd   & ' msglen=',msglen,' nbytes=',nbytes
5832 cd      write (iout,*) 'The received BUFFER array:'
5833 cd      do i=1,max_cont
5834 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5835 cd      enddo
5836         if (msglen.eq.msglen1) then
5837           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5838         else if (msglen.eq.msglen2)  then
5839           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5840           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5841         else
5842           write (iout,*)
5843      & 'ERROR!!!! message length changed while processing correlations.'
5844           write (*,*)
5845      & 'ERROR!!!! message length changed while processing correlations.'
5846           call mp_stopall(Error)
5847         endif ! msglen.eq.msglen1
5848       endif ! MyRank.lt.fgProcs-1
5849       if (ldone) goto 30
5850       ldone=.true.
5851       goto 10
5852    30 continue
5853 #endif
5854       if (lprn) then
5855         write (iout,'(a)') 'Contact function values:'
5856         do i=nnt,nct-2
5857           write (iout,'(2i3,50(1x,i2,f5.2))')
5858      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5859      &    j=1,num_cont_hb(i))
5860         enddo
5861       endif
5862       ecorr=0.0D0
5863 C Remove the loop below after debugging !!!
5864       do i=nnt,nct
5865         do j=1,3
5866           gradcorr(j,i)=0.0D0
5867           gradxorr(j,i)=0.0D0
5868         enddo
5869       enddo
5870 C Calculate the local-electrostatic correlation terms
5871       do i=iatel_s,iatel_e+1
5872         i1=i+1
5873         num_conti=num_cont_hb(i)
5874         num_conti1=num_cont_hb(i+1)
5875         do jj=1,num_conti
5876           j=jcont_hb(jj,i)
5877           do kk=1,num_conti1
5878             j1=jcont_hb(kk,i1)
5879 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5880 c     &         ' jj=',jj,' kk=',kk
5881             if (j1.eq.j+1 .or. j1.eq.j-1) then
5882 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5883 C The system gains extra energy.
5884               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5885               n_corr=n_corr+1
5886             else if (j1.eq.j) then
5887 C Contacts I-J and I-(J+1) occur simultaneously.
5888 C The system loses extra energy.
5889 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5890             endif
5891           enddo ! kk
5892           do kk=1,num_conti
5893             j1=jcont_hb(kk,i)
5894 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5895 c    &         ' jj=',jj,' kk=',kk
5896             if (j1.eq.j+1) then
5897 C Contacts I-J and (I+1)-J occur simultaneously.
5898 C The system loses extra energy.
5899 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5900             endif ! j1==j+1
5901           enddo ! kk
5902         enddo ! jj
5903       enddo ! i
5904       return
5905       end
5906 c------------------------------------------------------------------------------
5907       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5908      &  n_corr1)
5909 C This subroutine calculates multi-body contributions to hydrogen-bonding
5910       implicit real*8 (a-h,o-z)
5911       include 'DIMENSIONS'
5912       include 'sizesclu.dat'
5913       include 'COMMON.IOUNITS'
5914 #ifdef MPL
5915       include 'COMMON.INFO'
5916 #endif
5917       include 'COMMON.FFIELD'
5918       include 'COMMON.DERIV'
5919       include 'COMMON.INTERACT'
5920       include 'COMMON.CONTACTS'
5921 #ifdef MPL
5922       parameter (max_cont=maxconts)
5923       parameter (max_dim=2*(8*3+2))
5924       parameter (msglen1=max_cont*max_dim*4)
5925       parameter (msglen2=2*msglen1)
5926       integer source,CorrelType,CorrelID,Error
5927       double precision buffer(max_cont,max_dim)
5928 #endif
5929       double precision gx(3),gx1(3)
5930       logical lprn,ldone
5931
5932 C Set lprn=.true. for debugging
5933       lprn=.false.
5934       eturn6=0.0d0
5935 #ifdef MPL
5936       n_corr=0
5937       n_corr1=0
5938       if (fgProcs.le.1) goto 30
5939       if (lprn) then
5940         write (iout,'(a)') 'Contact function values:'
5941         do i=nnt,nct-2
5942           write (iout,'(2i3,50(1x,i2,f5.2))')
5943      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5944      &    j=1,num_cont_hb(i))
5945         enddo
5946       endif
5947 C Caution! Following code assumes that electrostatic interactions concerning
5948 C a given atom are split among at most two processors!
5949       CorrelType=477
5950       CorrelID=MyID+1
5951       ldone=.false.
5952       do i=1,max_cont
5953         do j=1,max_dim
5954           buffer(i,j)=0.0D0
5955         enddo
5956       enddo
5957       mm=mod(MyRank,2)
5958 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5959       if (mm) 20,20,10
5960    10 continue
5961 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5962       if (MyRank.gt.0) then
5963 C Send correlation contributions to the preceding processor
5964         msglen=msglen1
5965         nn=num_cont_hb(iatel_s)
5966         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5967 cd      write (iout,*) 'The BUFFER array:'
5968 cd      do i=1,nn
5969 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5970 cd      enddo
5971         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5972           msglen=msglen2
5973             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5974 C Clear the contacts of the atom passed to the neighboring processor
5975         nn=num_cont_hb(iatel_s+1)
5976 cd      do i=1,nn
5977 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5978 cd      enddo
5979             num_cont_hb(iatel_s)=0
5980         endif
5981 cd      write (iout,*) 'Processor ',MyID,MyRank,
5982 cd   & ' is sending correlation contribution to processor',MyID-1,
5983 cd   & ' msglen=',msglen
5984 cd      write (*,*) 'Processor ',MyID,MyRank,
5985 cd   & ' is sending correlation contribution to processor',MyID-1,
5986 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5987         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5988 cd      write (iout,*) 'Processor ',MyID,
5989 cd   & ' has sent correlation contribution to processor',MyID-1,
5990 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5991 cd      write (*,*) 'Processor ',MyID,
5992 cd   & ' has sent correlation contribution to processor',MyID-1,
5993 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5994         msglen=msglen1
5995       endif ! (MyRank.gt.0)
5996       if (ldone) goto 30
5997       ldone=.true.
5998    20 continue
5999 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6000       if (MyRank.lt.fgProcs-1) then
6001 C Receive correlation contributions from the next processor
6002         msglen=msglen1
6003         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6004 cd      write (iout,*) 'Processor',MyID,
6005 cd   & ' is receiving correlation contribution from processor',MyID+1,
6006 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6007 cd      write (*,*) 'Processor',MyID,
6008 cd   & ' is receiving correlation contribution from processor',MyID+1,
6009 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6010         nbytes=-1
6011         do while (nbytes.le.0)
6012           call mp_probe(MyID+1,CorrelType,nbytes)
6013         enddo
6014 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6015         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6016 cd      write (iout,*) 'Processor',MyID,
6017 cd   & ' has received correlation contribution from processor',MyID+1,
6018 cd   & ' msglen=',msglen,' nbytes=',nbytes
6019 cd      write (iout,*) 'The received BUFFER array:'
6020 cd      do i=1,max_cont
6021 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6022 cd      enddo
6023         if (msglen.eq.msglen1) then
6024           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6025         else if (msglen.eq.msglen2)  then
6026           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6027           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6028         else
6029           write (iout,*)
6030      & 'ERROR!!!! message length changed while processing correlations.'
6031           write (*,*)
6032      & 'ERROR!!!! message length changed while processing correlations.'
6033           call mp_stopall(Error)
6034         endif ! msglen.eq.msglen1
6035       endif ! MyRank.lt.fgProcs-1
6036       if (ldone) goto 30
6037       ldone=.true.
6038       goto 10
6039    30 continue
6040 #endif
6041       if (lprn) then
6042         write (iout,'(a)') 'Contact function values:'
6043         do i=nnt,nct-2
6044           write (iout,'(2i3,50(1x,i2,f5.2))')
6045      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6046      &    j=1,num_cont_hb(i))
6047         enddo
6048       endif
6049       ecorr=0.0D0
6050       ecorr5=0.0d0
6051       ecorr6=0.0d0
6052 C Remove the loop below after debugging !!!
6053       do i=nnt,nct
6054         do j=1,3
6055           gradcorr(j,i)=0.0D0
6056           gradxorr(j,i)=0.0D0
6057         enddo
6058       enddo
6059 C Calculate the dipole-dipole interaction energies
6060       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6061       do i=iatel_s,iatel_e+1
6062         num_conti=num_cont_hb(i)
6063         do jj=1,num_conti
6064           j=jcont_hb(jj,i)
6065           call dipole(i,j,jj)
6066         enddo
6067       enddo
6068       endif
6069 C Calculate the local-electrostatic correlation terms
6070       do i=iatel_s,iatel_e+1
6071         i1=i+1
6072         num_conti=num_cont_hb(i)
6073         num_conti1=num_cont_hb(i+1)
6074         do jj=1,num_conti
6075           j=jcont_hb(jj,i)
6076           do kk=1,num_conti1
6077             j1=jcont_hb(kk,i1)
6078 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6079 c     &         ' jj=',jj,' kk=',kk
6080             if (j1.eq.j+1 .or. j1.eq.j-1) then
6081 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6082 C The system gains extra energy.
6083               n_corr=n_corr+1
6084               sqd1=dsqrt(d_cont(jj,i))
6085               sqd2=dsqrt(d_cont(kk,i1))
6086               sred_geom = sqd1*sqd2
6087               IF (sred_geom.lt.cutoff_corr) THEN
6088                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6089      &            ekont,fprimcont)
6090 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6091 c     &         ' jj=',jj,' kk=',kk
6092                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6093                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6094                 do l=1,3
6095                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6096                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6097                 enddo
6098                 n_corr1=n_corr1+1
6099 cd               write (iout,*) 'sred_geom=',sred_geom,
6100 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6101                 call calc_eello(i,j,i+1,j1,jj,kk)
6102                 if (wcorr4.gt.0.0d0)
6103      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6104                 if (wcorr5.gt.0.0d0)
6105      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6106 c                print *,"wcorr5",ecorr5
6107 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6108 cd                write(2,*)'ijkl',i,j,i+1,j1
6109                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6110      &               .or. wturn6.eq.0.0d0))then
6111 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6112                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6113 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6114 cd     &            'ecorr6=',ecorr6
6115 cd                write (iout,'(4e15.5)') sred_geom,
6116 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6117 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6118 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6119                 else if (wturn6.gt.0.0d0
6120      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6121 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6122                   eturn6=eturn6+eello_turn6(i,jj,kk)
6123 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6124                 endif
6125               ENDIF
6126 1111          continue
6127             else if (j1.eq.j) then
6128 C Contacts I-J and I-(J+1) occur simultaneously.
6129 C The system loses extra energy.
6130 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6131             endif
6132           enddo ! kk
6133           do kk=1,num_conti
6134             j1=jcont_hb(kk,i)
6135 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6136 c    &         ' jj=',jj,' kk=',kk
6137             if (j1.eq.j+1) then
6138 C Contacts I-J and (I+1)-J occur simultaneously.
6139 C The system loses extra energy.
6140 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6141             endif ! j1==j+1
6142           enddo ! kk
6143         enddo ! jj
6144       enddo ! i
6145       return
6146       end
6147 c------------------------------------------------------------------------------
6148       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6149       implicit real*8 (a-h,o-z)
6150       include 'DIMENSIONS'
6151       include 'COMMON.IOUNITS'
6152       include 'COMMON.DERIV'
6153       include 'COMMON.INTERACT'
6154       include 'COMMON.CONTACTS'
6155       include 'COMMON.SHIELD'
6156
6157       double precision gx(3),gx1(3)
6158       logical lprn
6159       lprn=.false.
6160       eij=facont_hb(jj,i)
6161       ekl=facont_hb(kk,k)
6162       ees0pij=ees0p(jj,i)
6163       ees0pkl=ees0p(kk,k)
6164       ees0mij=ees0m(jj,i)
6165       ees0mkl=ees0m(kk,k)
6166       ekont=eij*ekl
6167       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6168 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6169 C Following 4 lines for diagnostics.
6170 cd    ees0pkl=0.0D0
6171 cd    ees0pij=1.0D0
6172 cd    ees0mkl=0.0D0
6173 cd    ees0mij=1.0D0
6174 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6175 c    &   ' and',k,l
6176 c     write (iout,*)'Contacts have occurred for peptide groups',
6177 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6178 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6179 C Calculate the multi-body contribution to energy.
6180       ecorr=ecorr+ekont*ees
6181       if (calc_grad) then
6182 C Calculate multi-body contributions to the gradient.
6183       do ll=1,3
6184         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6185         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6186      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6187      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6188         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6189      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6190      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6191         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6192         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6193      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6194      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6195         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6196      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6197      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6198       enddo
6199       do m=i+1,j-1
6200         do ll=1,3
6201           gradcorr(ll,m)=gradcorr(ll,m)+
6202      &     ees*ekl*gacont_hbr(ll,jj,i)-
6203      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6204      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6205         enddo
6206       enddo
6207       do m=k+1,l-1
6208         do ll=1,3
6209           gradcorr(ll,m)=gradcorr(ll,m)+
6210      &     ees*eij*gacont_hbr(ll,kk,k)-
6211      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6212      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6213         enddo
6214       enddo
6215       if (shield_mode.gt.0) then
6216        j=ees0plist(jj,i)
6217        l=ees0plist(kk,k)
6218 C        print *,i,j,fac_shield(i),fac_shield(j),
6219 C     &fac_shield(k),fac_shield(l)
6220         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6221      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6222           do ilist=1,ishield_list(i)
6223            iresshield=shield_list(ilist,i)
6224            do m=1,3
6225            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6226 C     &      *2.0
6227            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6228      &              rlocshield
6229      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6230             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6231      &+rlocshield
6232            enddo
6233           enddo
6234           do ilist=1,ishield_list(j)
6235            iresshield=shield_list(ilist,j)
6236            do m=1,3
6237            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6238 C     &     *2.0
6239            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6240      &              rlocshield
6241      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6242            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6243      &     +rlocshield
6244            enddo
6245           enddo
6246           do ilist=1,ishield_list(k)
6247            iresshield=shield_list(ilist,k)
6248            do m=1,3
6249            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6250 C     &     *2.0
6251            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6252      &              rlocshield
6253      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6254            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6255      &     +rlocshield
6256            enddo
6257           enddo
6258           do ilist=1,ishield_list(l)
6259            iresshield=shield_list(ilist,l)
6260            do m=1,3
6261            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6262 C     &     *2.0
6263            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6264      &              rlocshield
6265      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6266            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6267      &     +rlocshield
6268            enddo
6269           enddo
6270 C          print *,gshieldx(m,iresshield)
6271           do m=1,3
6272             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6273      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6274             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6275      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6276             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6277      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6278             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6279      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6280
6281             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6282      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6283             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6284      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6285             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6286      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6287             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6288      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6289
6290            enddo
6291       endif
6292       endif
6293       endif
6294       ehbcorr=ekont*ees
6295       return
6296       end
6297 C---------------------------------------------------------------------------
6298       subroutine dipole(i,j,jj)
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'sizesclu.dat'
6302       include 'COMMON.IOUNITS'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.FFIELD'
6305       include 'COMMON.DERIV'
6306       include 'COMMON.INTERACT'
6307       include 'COMMON.CONTACTS'
6308       include 'COMMON.TORSION'
6309       include 'COMMON.VAR'
6310       include 'COMMON.GEO'
6311       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6312      &  auxmat(2,2)
6313       iti1 = itortyp(itype(i+1))
6314       if (j.lt.nres-1) then
6315         if (itype(j).le.ntyp) then
6316           itj1 = itortyp(itype(j+1))
6317         else
6318           itj1=ntortyp+1
6319         endif
6320       else
6321         itj1=ntortyp+1
6322       endif
6323       do iii=1,2
6324         dipi(iii,1)=Ub2(iii,i)
6325         dipderi(iii)=Ub2der(iii,i)
6326         dipi(iii,2)=b1(iii,iti1)
6327         dipj(iii,1)=Ub2(iii,j)
6328         dipderj(iii)=Ub2der(iii,j)
6329         dipj(iii,2)=b1(iii,itj1)
6330       enddo
6331       kkk=0
6332       do iii=1,2
6333         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6334         do jjj=1,2
6335           kkk=kkk+1
6336           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6337         enddo
6338       enddo
6339       if (.not.calc_grad) return
6340       do kkk=1,5
6341         do lll=1,3
6342           mmm=0
6343           do iii=1,2
6344             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6345      &        auxvec(1))
6346             do jjj=1,2
6347               mmm=mmm+1
6348               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6349             enddo
6350           enddo
6351         enddo
6352       enddo
6353       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6354       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6355       do iii=1,2
6356         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6357       enddo
6358       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6359       do iii=1,2
6360         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6361       enddo
6362       return
6363       end
6364 C---------------------------------------------------------------------------
6365       subroutine calc_eello(i,j,k,l,jj,kk)
6366 C
6367 C This subroutine computes matrices and vectors needed to calculate
6368 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6369 C
6370       implicit real*8 (a-h,o-z)
6371       include 'DIMENSIONS'
6372       include 'sizesclu.dat'
6373       include 'COMMON.IOUNITS'
6374       include 'COMMON.CHAIN'
6375       include 'COMMON.DERIV'
6376       include 'COMMON.INTERACT'
6377       include 'COMMON.CONTACTS'
6378       include 'COMMON.TORSION'
6379       include 'COMMON.VAR'
6380       include 'COMMON.GEO'
6381       include 'COMMON.FFIELD'
6382       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6383      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6384       logical lprn
6385       common /kutas/ lprn
6386 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6387 cd     & ' jj=',jj,' kk=',kk
6388 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6389       do iii=1,2
6390         do jjj=1,2
6391           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6392           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6393         enddo
6394       enddo
6395       call transpose2(aa1(1,1),aa1t(1,1))
6396       call transpose2(aa2(1,1),aa2t(1,1))
6397       do kkk=1,5
6398         do lll=1,3
6399           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6400      &      aa1tder(1,1,lll,kkk))
6401           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6402      &      aa2tder(1,1,lll,kkk))
6403         enddo
6404       enddo
6405       if (l.eq.j+1) then
6406 C parallel orientation of the two CA-CA-CA frames.
6407 c        if (i.gt.1) then
6408         if (i.gt.1 .and. itype(i).le.ntyp) then
6409           iti=itortyp(itype(i))
6410         else
6411           iti=ntortyp+1
6412         endif
6413         itk1=itortyp(itype(k+1))
6414         itj=itortyp(itype(j))
6415 c        if (l.lt.nres-1) then
6416         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6417           itl1=itortyp(itype(l+1))
6418         else
6419           itl1=ntortyp+1
6420         endif
6421 C A1 kernel(j+1) A2T
6422 cd        do iii=1,2
6423 cd          write (iout,'(3f10.5,5x,3f10.5)')
6424 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6425 cd        enddo
6426         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6427      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6428      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6429 C Following matrices are needed only for 6-th order cumulants
6430         IF (wcorr6.gt.0.0d0) THEN
6431         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6432      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6433      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6434         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6435      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6436      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6437      &   ADtEAderx(1,1,1,1,1,1))
6438         lprn=.false.
6439         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6440      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6441      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6442      &   ADtEA1derx(1,1,1,1,1,1))
6443         ENDIF
6444 C End 6-th order cumulants
6445 cd        lprn=.false.
6446 cd        if (lprn) then
6447 cd        write (2,*) 'In calc_eello6'
6448 cd        do iii=1,2
6449 cd          write (2,*) 'iii=',iii
6450 cd          do kkk=1,5
6451 cd            write (2,*) 'kkk=',kkk
6452 cd            do jjj=1,2
6453 cd              write (2,'(3(2f10.5),5x)')
6454 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6455 cd            enddo
6456 cd          enddo
6457 cd        enddo
6458 cd        endif
6459         call transpose2(EUgder(1,1,k),auxmat(1,1))
6460         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6461         call transpose2(EUg(1,1,k),auxmat(1,1))
6462         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6463         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6464         do iii=1,2
6465           do kkk=1,5
6466             do lll=1,3
6467               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6468      &          EAEAderx(1,1,lll,kkk,iii,1))
6469             enddo
6470           enddo
6471         enddo
6472 C A1T kernel(i+1) A2
6473         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6474      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6475      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6476 C Following matrices are needed only for 6-th order cumulants
6477         IF (wcorr6.gt.0.0d0) THEN
6478         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6479      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6480      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6481         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6482      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6483      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6484      &   ADtEAderx(1,1,1,1,1,2))
6485         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6486      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6487      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6488      &   ADtEA1derx(1,1,1,1,1,2))
6489         ENDIF
6490 C End 6-th order cumulants
6491         call transpose2(EUgder(1,1,l),auxmat(1,1))
6492         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6493         call transpose2(EUg(1,1,l),auxmat(1,1))
6494         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6495         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6496         do iii=1,2
6497           do kkk=1,5
6498             do lll=1,3
6499               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6500      &          EAEAderx(1,1,lll,kkk,iii,2))
6501             enddo
6502           enddo
6503         enddo
6504 C AEAb1 and AEAb2
6505 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6506 C They are needed only when the fifth- or the sixth-order cumulants are
6507 C indluded.
6508         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6509         call transpose2(AEA(1,1,1),auxmat(1,1))
6510         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6511         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6512         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6513         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6514         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6515         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6516         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6517         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6518         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6519         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6520         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6521         call transpose2(AEA(1,1,2),auxmat(1,1))
6522         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6523         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6524         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6525         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6526         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6527         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6528         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6529         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6530         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6531         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6532         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6533 C Calculate the Cartesian derivatives of the vectors.
6534         do iii=1,2
6535           do kkk=1,5
6536             do lll=1,3
6537               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6538               call matvec2(auxmat(1,1),b1(1,iti),
6539      &          AEAb1derx(1,lll,kkk,iii,1,1))
6540               call matvec2(auxmat(1,1),Ub2(1,i),
6541      &          AEAb2derx(1,lll,kkk,iii,1,1))
6542               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6543      &          AEAb1derx(1,lll,kkk,iii,2,1))
6544               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6545      &          AEAb2derx(1,lll,kkk,iii,2,1))
6546               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6547               call matvec2(auxmat(1,1),b1(1,itj),
6548      &          AEAb1derx(1,lll,kkk,iii,1,2))
6549               call matvec2(auxmat(1,1),Ub2(1,j),
6550      &          AEAb2derx(1,lll,kkk,iii,1,2))
6551               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6552      &          AEAb1derx(1,lll,kkk,iii,2,2))
6553               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6554      &          AEAb2derx(1,lll,kkk,iii,2,2))
6555             enddo
6556           enddo
6557         enddo
6558         ENDIF
6559 C End vectors
6560       else
6561 C Antiparallel orientation of the two CA-CA-CA frames.
6562 c        if (i.gt.1) then
6563         if (i.gt.1 .and. itype(i).le.ntyp) then
6564           iti=itortyp(itype(i))
6565         else
6566           iti=ntortyp+1
6567         endif
6568         itk1=itortyp(itype(k+1))
6569         itl=itortyp(itype(l))
6570         itj=itortyp(itype(j))
6571 c        if (j.lt.nres-1) then
6572         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6573           itj1=itortyp(itype(j+1))
6574         else
6575           itj1=ntortyp+1
6576         endif
6577 C A2 kernel(j-1)T A1T
6578         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6579      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6580      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6581 C Following matrices are needed only for 6-th order cumulants
6582         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6583      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6584         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6585      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6586      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6587         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6588      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6589      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6590      &   ADtEAderx(1,1,1,1,1,1))
6591         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6592      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6593      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6594      &   ADtEA1derx(1,1,1,1,1,1))
6595         ENDIF
6596 C End 6-th order cumulants
6597         call transpose2(EUgder(1,1,k),auxmat(1,1))
6598         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6599         call transpose2(EUg(1,1,k),auxmat(1,1))
6600         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6601         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6602         do iii=1,2
6603           do kkk=1,5
6604             do lll=1,3
6605               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6606      &          EAEAderx(1,1,lll,kkk,iii,1))
6607             enddo
6608           enddo
6609         enddo
6610 C A2T kernel(i+1)T A1
6611         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6612      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6613      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6614 C Following matrices are needed only for 6-th order cumulants
6615         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6616      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6617         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6618      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6619      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6620         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6621      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6622      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6623      &   ADtEAderx(1,1,1,1,1,2))
6624         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6625      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6626      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6627      &   ADtEA1derx(1,1,1,1,1,2))
6628         ENDIF
6629 C End 6-th order cumulants
6630         call transpose2(EUgder(1,1,j),auxmat(1,1))
6631         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6632         call transpose2(EUg(1,1,j),auxmat(1,1))
6633         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6634         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6635         do iii=1,2
6636           do kkk=1,5
6637             do lll=1,3
6638               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6639      &          EAEAderx(1,1,lll,kkk,iii,2))
6640             enddo
6641           enddo
6642         enddo
6643 C AEAb1 and AEAb2
6644 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6645 C They are needed only when the fifth- or the sixth-order cumulants are
6646 C indluded.
6647         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6648      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6649         call transpose2(AEA(1,1,1),auxmat(1,1))
6650         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6651         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6652         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6653         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6654         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6655         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6656         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6657         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6658         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6659         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6660         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6661         call transpose2(AEA(1,1,2),auxmat(1,1))
6662         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6663         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6664         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6665         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6666         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6667         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6668         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6669         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6670         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6671         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6672         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6673 C Calculate the Cartesian derivatives of the vectors.
6674         do iii=1,2
6675           do kkk=1,5
6676             do lll=1,3
6677               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6678               call matvec2(auxmat(1,1),b1(1,iti),
6679      &          AEAb1derx(1,lll,kkk,iii,1,1))
6680               call matvec2(auxmat(1,1),Ub2(1,i),
6681      &          AEAb2derx(1,lll,kkk,iii,1,1))
6682               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6683      &          AEAb1derx(1,lll,kkk,iii,2,1))
6684               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6685      &          AEAb2derx(1,lll,kkk,iii,2,1))
6686               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6687               call matvec2(auxmat(1,1),b1(1,itl),
6688      &          AEAb1derx(1,lll,kkk,iii,1,2))
6689               call matvec2(auxmat(1,1),Ub2(1,l),
6690      &          AEAb2derx(1,lll,kkk,iii,1,2))
6691               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6692      &          AEAb1derx(1,lll,kkk,iii,2,2))
6693               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6694      &          AEAb2derx(1,lll,kkk,iii,2,2))
6695             enddo
6696           enddo
6697         enddo
6698         ENDIF
6699 C End vectors
6700       endif
6701       return
6702       end
6703 C---------------------------------------------------------------------------
6704       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6705      &  KK,KKderg,AKA,AKAderg,AKAderx)
6706       implicit none
6707       integer nderg
6708       logical transp
6709       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6710      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6711      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6712       integer iii,kkk,lll
6713       integer jjj,mmm
6714       logical lprn
6715       common /kutas/ lprn
6716       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6717       do iii=1,nderg
6718         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6719      &    AKAderg(1,1,iii))
6720       enddo
6721 cd      if (lprn) write (2,*) 'In kernel'
6722       do kkk=1,5
6723 cd        if (lprn) write (2,*) 'kkk=',kkk
6724         do lll=1,3
6725           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6726      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6727 cd          if (lprn) then
6728 cd            write (2,*) 'lll=',lll
6729 cd            write (2,*) 'iii=1'
6730 cd            do jjj=1,2
6731 cd              write (2,'(3(2f10.5),5x)')
6732 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6733 cd            enddo
6734 cd          endif
6735           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6736      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6737 cd          if (lprn) then
6738 cd            write (2,*) 'lll=',lll
6739 cd            write (2,*) 'iii=2'
6740 cd            do jjj=1,2
6741 cd              write (2,'(3(2f10.5),5x)')
6742 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6743 cd            enddo
6744 cd          endif
6745         enddo
6746       enddo
6747       return
6748       end
6749 C---------------------------------------------------------------------------
6750       double precision function eello4(i,j,k,l,jj,kk)
6751       implicit real*8 (a-h,o-z)
6752       include 'DIMENSIONS'
6753       include 'sizesclu.dat'
6754       include 'COMMON.IOUNITS'
6755       include 'COMMON.CHAIN'
6756       include 'COMMON.DERIV'
6757       include 'COMMON.INTERACT'
6758       include 'COMMON.CONTACTS'
6759       include 'COMMON.TORSION'
6760       include 'COMMON.VAR'
6761       include 'COMMON.GEO'
6762       double precision pizda(2,2),ggg1(3),ggg2(3)
6763 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6764 cd        eello4=0.0d0
6765 cd        return
6766 cd      endif
6767 cd      print *,'eello4:',i,j,k,l,jj,kk
6768 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6769 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6770 cold      eij=facont_hb(jj,i)
6771 cold      ekl=facont_hb(kk,k)
6772 cold      ekont=eij*ekl
6773       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6774       if (calc_grad) then
6775 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6776       gcorr_loc(k-1)=gcorr_loc(k-1)
6777      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6778       if (l.eq.j+1) then
6779         gcorr_loc(l-1)=gcorr_loc(l-1)
6780      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6781       else
6782         gcorr_loc(j-1)=gcorr_loc(j-1)
6783      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6784       endif
6785       do iii=1,2
6786         do kkk=1,5
6787           do lll=1,3
6788             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6789      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6790 cd            derx(lll,kkk,iii)=0.0d0
6791           enddo
6792         enddo
6793       enddo
6794 cd      gcorr_loc(l-1)=0.0d0
6795 cd      gcorr_loc(j-1)=0.0d0
6796 cd      gcorr_loc(k-1)=0.0d0
6797 cd      eel4=1.0d0
6798 cd      write (iout,*)'Contacts have occurred for peptide groups',
6799 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6800 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6801       if (j.lt.nres-1) then
6802         j1=j+1
6803         j2=j-1
6804       else
6805         j1=j-1
6806         j2=j-2
6807       endif
6808       if (l.lt.nres-1) then
6809         l1=l+1
6810         l2=l-1
6811       else
6812         l1=l-1
6813         l2=l-2
6814       endif
6815       do ll=1,3
6816 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6817         ggg1(ll)=eel4*g_contij(ll,1)
6818         ggg2(ll)=eel4*g_contij(ll,2)
6819         ghalf=0.5d0*ggg1(ll)
6820 cd        ghalf=0.0d0
6821         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6822         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6823         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6824         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6825 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6826         ghalf=0.5d0*ggg2(ll)
6827 cd        ghalf=0.0d0
6828         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6829         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6830         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6831         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6832       enddo
6833 cd      goto 1112
6834       do m=i+1,j-1
6835         do ll=1,3
6836 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6837           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6838         enddo
6839       enddo
6840       do m=k+1,l-1
6841         do ll=1,3
6842 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6843           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6844         enddo
6845       enddo
6846 1112  continue
6847       do m=i+2,j2
6848         do ll=1,3
6849           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6850         enddo
6851       enddo
6852       do m=k+2,l2
6853         do ll=1,3
6854           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6855         enddo
6856       enddo
6857 cd      do iii=1,nres-3
6858 cd        write (2,*) iii,gcorr_loc(iii)
6859 cd      enddo
6860       endif
6861       eello4=ekont*eel4
6862 cd      write (2,*) 'ekont',ekont
6863 cd      write (iout,*) 'eello4',ekont*eel4
6864       return
6865       end
6866 C---------------------------------------------------------------------------
6867       double precision function eello5(i,j,k,l,jj,kk)
6868       implicit real*8 (a-h,o-z)
6869       include 'DIMENSIONS'
6870       include 'sizesclu.dat'
6871       include 'COMMON.IOUNITS'
6872       include 'COMMON.CHAIN'
6873       include 'COMMON.DERIV'
6874       include 'COMMON.INTERACT'
6875       include 'COMMON.CONTACTS'
6876       include 'COMMON.TORSION'
6877       include 'COMMON.VAR'
6878       include 'COMMON.GEO'
6879       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6880       double precision ggg1(3),ggg2(3)
6881 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6882 C                                                                              C
6883 C                            Parallel chains                                   C
6884 C                                                                              C
6885 C          o             o                   o             o                   C
6886 C         /l\           / \             \   / \           / \   /              C
6887 C        /   \         /   \             \ /   \         /   \ /               C
6888 C       j| o |l1       | o |              o| o |         | o |o                C
6889 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6890 C      \i/   \         /   \ /             /   \         /   \                 C
6891 C       o    k1             o                                                  C
6892 C         (I)          (II)                (III)          (IV)                 C
6893 C                                                                              C
6894 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6895 C                                                                              C
6896 C                            Antiparallel chains                               C
6897 C                                                                              C
6898 C          o             o                   o             o                   C
6899 C         /j\           / \             \   / \           / \   /              C
6900 C        /   \         /   \             \ /   \         /   \ /               C
6901 C      j1| o |l        | o |              o| o |         | o |o                C
6902 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6903 C      \i/   \         /   \ /             /   \         /   \                 C
6904 C       o     k1            o                                                  C
6905 C         (I)          (II)                (III)          (IV)                 C
6906 C                                                                              C
6907 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6908 C                                                                              C
6909 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6910 C                                                                              C
6911 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6912 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6913 cd        eello5=0.0d0
6914 cd        return
6915 cd      endif
6916 cd      write (iout,*)
6917 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6918 cd     &   ' and',k,l
6919       itk=itortyp(itype(k))
6920       itl=itortyp(itype(l))
6921       itj=itortyp(itype(j))
6922       eello5_1=0.0d0
6923       eello5_2=0.0d0
6924       eello5_3=0.0d0
6925       eello5_4=0.0d0
6926 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6927 cd     &   eel5_3_num,eel5_4_num)
6928       do iii=1,2
6929         do kkk=1,5
6930           do lll=1,3
6931             derx(lll,kkk,iii)=0.0d0
6932           enddo
6933         enddo
6934       enddo
6935 cd      eij=facont_hb(jj,i)
6936 cd      ekl=facont_hb(kk,k)
6937 cd      ekont=eij*ekl
6938 cd      write (iout,*)'Contacts have occurred for peptide groups',
6939 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6940 cd      goto 1111
6941 C Contribution from the graph I.
6942 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6943 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6944       call transpose2(EUg(1,1,k),auxmat(1,1))
6945       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6946       vv(1)=pizda(1,1)-pizda(2,2)
6947       vv(2)=pizda(1,2)+pizda(2,1)
6948       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6949      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6950       if (calc_grad) then
6951 C Explicit gradient in virtual-dihedral angles.
6952       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6953      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6954      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6955       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6956       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6957       vv(1)=pizda(1,1)-pizda(2,2)
6958       vv(2)=pizda(1,2)+pizda(2,1)
6959       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6960      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6961      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6962       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6963       vv(1)=pizda(1,1)-pizda(2,2)
6964       vv(2)=pizda(1,2)+pizda(2,1)
6965       if (l.eq.j+1) then
6966         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6967      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6968      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6969       else
6970         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6971      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6972      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6973       endif
6974 C Cartesian gradient
6975       do iii=1,2
6976         do kkk=1,5
6977           do lll=1,3
6978             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6979      &        pizda(1,1))
6980             vv(1)=pizda(1,1)-pizda(2,2)
6981             vv(2)=pizda(1,2)+pizda(2,1)
6982             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6983      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6984      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6985           enddo
6986         enddo
6987       enddo
6988 c      goto 1112
6989       endif
6990 c1111  continue
6991 C Contribution from graph II
6992       call transpose2(EE(1,1,itk),auxmat(1,1))
6993       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6994       vv(1)=pizda(1,1)+pizda(2,2)
6995       vv(2)=pizda(2,1)-pizda(1,2)
6996       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6997      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6998       if (calc_grad) then
6999 C Explicit gradient in virtual-dihedral angles.
7000       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7001      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7002       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7003       vv(1)=pizda(1,1)+pizda(2,2)
7004       vv(2)=pizda(2,1)-pizda(1,2)
7005       if (l.eq.j+1) then
7006         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7007      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7008      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7009       else
7010         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7011      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7012      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7013       endif
7014 C Cartesian gradient
7015       do iii=1,2
7016         do kkk=1,5
7017           do lll=1,3
7018             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7019      &        pizda(1,1))
7020             vv(1)=pizda(1,1)+pizda(2,2)
7021             vv(2)=pizda(2,1)-pizda(1,2)
7022             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7023      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7024      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7025           enddo
7026         enddo
7027       enddo
7028 cd      goto 1112
7029       endif
7030 cd1111  continue
7031       if (l.eq.j+1) then
7032 cd        goto 1110
7033 C Parallel orientation
7034 C Contribution from graph III
7035         call transpose2(EUg(1,1,l),auxmat(1,1))
7036         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7037         vv(1)=pizda(1,1)-pizda(2,2)
7038         vv(2)=pizda(1,2)+pizda(2,1)
7039         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7040      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7041         if (calc_grad) then
7042 C Explicit gradient in virtual-dihedral angles.
7043         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7044      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7045      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7046         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7047         vv(1)=pizda(1,1)-pizda(2,2)
7048         vv(2)=pizda(1,2)+pizda(2,1)
7049         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7050      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7051      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7052         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7053         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7054         vv(1)=pizda(1,1)-pizda(2,2)
7055         vv(2)=pizda(1,2)+pizda(2,1)
7056         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7057      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7058      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7059 C Cartesian gradient
7060         do iii=1,2
7061           do kkk=1,5
7062             do lll=1,3
7063               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7064      &          pizda(1,1))
7065               vv(1)=pizda(1,1)-pizda(2,2)
7066               vv(2)=pizda(1,2)+pizda(2,1)
7067               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7068      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7069      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7070             enddo
7071           enddo
7072         enddo
7073 cd        goto 1112
7074         endif
7075 C Contribution from graph IV
7076 cd1110    continue
7077         call transpose2(EE(1,1,itl),auxmat(1,1))
7078         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7079         vv(1)=pizda(1,1)+pizda(2,2)
7080         vv(2)=pizda(2,1)-pizda(1,2)
7081         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7082      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7083         if (calc_grad) then
7084 C Explicit gradient in virtual-dihedral angles.
7085         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7086      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7087         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7088         vv(1)=pizda(1,1)+pizda(2,2)
7089         vv(2)=pizda(2,1)-pizda(1,2)
7090         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7091      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7092      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7093 C Cartesian gradient
7094         do iii=1,2
7095           do kkk=1,5
7096             do lll=1,3
7097               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7098      &          pizda(1,1))
7099               vv(1)=pizda(1,1)+pizda(2,2)
7100               vv(2)=pizda(2,1)-pizda(1,2)
7101               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7102      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7103      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7104             enddo
7105           enddo
7106         enddo
7107         endif
7108       else
7109 C Antiparallel orientation
7110 C Contribution from graph III
7111 c        goto 1110
7112         call transpose2(EUg(1,1,j),auxmat(1,1))
7113         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7114         vv(1)=pizda(1,1)-pizda(2,2)
7115         vv(2)=pizda(1,2)+pizda(2,1)
7116         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7117      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7118         if (calc_grad) then
7119 C Explicit gradient in virtual-dihedral angles.
7120         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7121      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7122      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7123         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7124         vv(1)=pizda(1,1)-pizda(2,2)
7125         vv(2)=pizda(1,2)+pizda(2,1)
7126         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7127      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7128      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7129         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7130         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7131         vv(1)=pizda(1,1)-pizda(2,2)
7132         vv(2)=pizda(1,2)+pizda(2,1)
7133         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7134      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7135      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7136 C Cartesian gradient
7137         do iii=1,2
7138           do kkk=1,5
7139             do lll=1,3
7140               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7141      &          pizda(1,1))
7142               vv(1)=pizda(1,1)-pizda(2,2)
7143               vv(2)=pizda(1,2)+pizda(2,1)
7144               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7145      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7146      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7147             enddo
7148           enddo
7149         enddo
7150 cd        goto 1112
7151         endif
7152 C Contribution from graph IV
7153 1110    continue
7154         call transpose2(EE(1,1,itj),auxmat(1,1))
7155         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7156         vv(1)=pizda(1,1)+pizda(2,2)
7157         vv(2)=pizda(2,1)-pizda(1,2)
7158         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7159      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7160         if (calc_grad) then
7161 C Explicit gradient in virtual-dihedral angles.
7162         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7163      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7164         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7165         vv(1)=pizda(1,1)+pizda(2,2)
7166         vv(2)=pizda(2,1)-pizda(1,2)
7167         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7168      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7169      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7170 C Cartesian gradient
7171         do iii=1,2
7172           do kkk=1,5
7173             do lll=1,3
7174               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7175      &          pizda(1,1))
7176               vv(1)=pizda(1,1)+pizda(2,2)
7177               vv(2)=pizda(2,1)-pizda(1,2)
7178               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7179      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7180      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7181             enddo
7182           enddo
7183         enddo
7184       endif
7185       endif
7186 1112  continue
7187       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7188 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7189 cd        write (2,*) 'ijkl',i,j,k,l
7190 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7191 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7192 cd      endif
7193 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7194 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7195 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7196 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7197       if (calc_grad) then
7198       if (j.lt.nres-1) then
7199         j1=j+1
7200         j2=j-1
7201       else
7202         j1=j-1
7203         j2=j-2
7204       endif
7205       if (l.lt.nres-1) then
7206         l1=l+1
7207         l2=l-1
7208       else
7209         l1=l-1
7210         l2=l-2
7211       endif
7212 cd      eij=1.0d0
7213 cd      ekl=1.0d0
7214 cd      ekont=1.0d0
7215 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7216       do ll=1,3
7217         ggg1(ll)=eel5*g_contij(ll,1)
7218         ggg2(ll)=eel5*g_contij(ll,2)
7219 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7220         ghalf=0.5d0*ggg1(ll)
7221 cd        ghalf=0.0d0
7222         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7223         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7224         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7225         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7226 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7227         ghalf=0.5d0*ggg2(ll)
7228 cd        ghalf=0.0d0
7229         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7230         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7231         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7232         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7233       enddo
7234 cd      goto 1112
7235       do m=i+1,j-1
7236         do ll=1,3
7237 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7238           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7239         enddo
7240       enddo
7241       do m=k+1,l-1
7242         do ll=1,3
7243 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7244           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7245         enddo
7246       enddo
7247 c1112  continue
7248       do m=i+2,j2
7249         do ll=1,3
7250           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7251         enddo
7252       enddo
7253       do m=k+2,l2
7254         do ll=1,3
7255           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7256         enddo
7257       enddo
7258 cd      do iii=1,nres-3
7259 cd        write (2,*) iii,g_corr5_loc(iii)
7260 cd      enddo
7261       endif
7262       eello5=ekont*eel5
7263 cd      write (2,*) 'ekont',ekont
7264 cd      write (iout,*) 'eello5',ekont*eel5
7265       return
7266       end
7267 c--------------------------------------------------------------------------
7268       double precision function eello6(i,j,k,l,jj,kk)
7269       implicit real*8 (a-h,o-z)
7270       include 'DIMENSIONS'
7271       include 'sizesclu.dat'
7272       include 'COMMON.IOUNITS'
7273       include 'COMMON.CHAIN'
7274       include 'COMMON.DERIV'
7275       include 'COMMON.INTERACT'
7276       include 'COMMON.CONTACTS'
7277       include 'COMMON.TORSION'
7278       include 'COMMON.VAR'
7279       include 'COMMON.GEO'
7280       include 'COMMON.FFIELD'
7281       double precision ggg1(3),ggg2(3)
7282 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7283 cd        eello6=0.0d0
7284 cd        return
7285 cd      endif
7286 cd      write (iout,*)
7287 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7288 cd     &   ' and',k,l
7289       eello6_1=0.0d0
7290       eello6_2=0.0d0
7291       eello6_3=0.0d0
7292       eello6_4=0.0d0
7293       eello6_5=0.0d0
7294       eello6_6=0.0d0
7295 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7296 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7297       do iii=1,2
7298         do kkk=1,5
7299           do lll=1,3
7300             derx(lll,kkk,iii)=0.0d0
7301           enddo
7302         enddo
7303       enddo
7304 cd      eij=facont_hb(jj,i)
7305 cd      ekl=facont_hb(kk,k)
7306 cd      ekont=eij*ekl
7307 cd      eij=1.0d0
7308 cd      ekl=1.0d0
7309 cd      ekont=1.0d0
7310       if (l.eq.j+1) then
7311         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7312         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7313         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7314         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7315         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7316         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7317       else
7318         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7319         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7320         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7321         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7322         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7323           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7324         else
7325           eello6_5=0.0d0
7326         endif
7327         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7328       endif
7329 C If turn contributions are considered, they will be handled separately.
7330       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7331 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7332 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7333 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7334 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7335 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7336 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7337 cd      goto 1112
7338       if (calc_grad) then
7339       if (j.lt.nres-1) then
7340         j1=j+1
7341         j2=j-1
7342       else
7343         j1=j-1
7344         j2=j-2
7345       endif
7346       if (l.lt.nres-1) then
7347         l1=l+1
7348         l2=l-1
7349       else
7350         l1=l-1
7351         l2=l-2
7352       endif
7353       do ll=1,3
7354         ggg1(ll)=eel6*g_contij(ll,1)
7355         ggg2(ll)=eel6*g_contij(ll,2)
7356 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7357         ghalf=0.5d0*ggg1(ll)
7358 cd        ghalf=0.0d0
7359         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7360         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7361         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7362         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7363         ghalf=0.5d0*ggg2(ll)
7364 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7365 cd        ghalf=0.0d0
7366         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7367         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7368         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7369         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7370       enddo
7371 cd      goto 1112
7372       do m=i+1,j-1
7373         do ll=1,3
7374 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7375           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7376         enddo
7377       enddo
7378       do m=k+1,l-1
7379         do ll=1,3
7380 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7381           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7382         enddo
7383       enddo
7384 1112  continue
7385       do m=i+2,j2
7386         do ll=1,3
7387           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7388         enddo
7389       enddo
7390       do m=k+2,l2
7391         do ll=1,3
7392           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7393         enddo
7394       enddo
7395 cd      do iii=1,nres-3
7396 cd        write (2,*) iii,g_corr6_loc(iii)
7397 cd      enddo
7398       endif
7399       eello6=ekont*eel6
7400 cd      write (2,*) 'ekont',ekont
7401 cd      write (iout,*) 'eello6',ekont*eel6
7402       return
7403       end
7404 c--------------------------------------------------------------------------
7405       double precision function eello6_graph1(i,j,k,l,imat,swap)
7406       implicit real*8 (a-h,o-z)
7407       include 'DIMENSIONS'
7408       include 'sizesclu.dat'
7409       include 'COMMON.IOUNITS'
7410       include 'COMMON.CHAIN'
7411       include 'COMMON.DERIV'
7412       include 'COMMON.INTERACT'
7413       include 'COMMON.CONTACTS'
7414       include 'COMMON.TORSION'
7415       include 'COMMON.VAR'
7416       include 'COMMON.GEO'
7417       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7418       logical swap
7419       logical lprn
7420       common /kutas/ lprn
7421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7422 C                                                                              C
7423 C      Parallel       Antiparallel                                             C
7424 C                                                                              C
7425 C          o             o                                                     C
7426 C         /l\           /j\                                                    C
7427 C        /   \         /   \                                                   C
7428 C       /| o |         | o |\                                                  C
7429 C     \ j|/k\|  /   \  |/k\|l /                                                C
7430 C      \ /   \ /     \ /   \ /                                                 C
7431 C       o     o       o     o                                                  C
7432 C       i             i                                                        C
7433 C                                                                              C
7434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7435       itk=itortyp(itype(k))
7436       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7437       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7438       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7439       call transpose2(EUgC(1,1,k),auxmat(1,1))
7440       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7441       vv1(1)=pizda1(1,1)-pizda1(2,2)
7442       vv1(2)=pizda1(1,2)+pizda1(2,1)
7443       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7444       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7445       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7446       s5=scalar2(vv(1),Dtobr2(1,i))
7447 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7448       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7449       if (.not. calc_grad) return
7450       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7451      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7452      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7453      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7454      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7455      & +scalar2(vv(1),Dtobr2der(1,i)))
7456       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7457       vv1(1)=pizda1(1,1)-pizda1(2,2)
7458       vv1(2)=pizda1(1,2)+pizda1(2,1)
7459       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7460       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7461       if (l.eq.j+1) then
7462         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7463      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7464      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7465      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7466      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7467       else
7468         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7469      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7470      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7471      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7472      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7473       endif
7474       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7475       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7476       vv1(1)=pizda1(1,1)-pizda1(2,2)
7477       vv1(2)=pizda1(1,2)+pizda1(2,1)
7478       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7479      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7480      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7481      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7482       do iii=1,2
7483         if (swap) then
7484           ind=3-iii
7485         else
7486           ind=iii
7487         endif
7488         do kkk=1,5
7489           do lll=1,3
7490             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7491             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7492             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7493             call transpose2(EUgC(1,1,k),auxmat(1,1))
7494             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7495      &        pizda1(1,1))
7496             vv1(1)=pizda1(1,1)-pizda1(2,2)
7497             vv1(2)=pizda1(1,2)+pizda1(2,1)
7498             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7499             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7500      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7501             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7502      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7503             s5=scalar2(vv(1),Dtobr2(1,i))
7504             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7505           enddo
7506         enddo
7507       enddo
7508       return
7509       end
7510 c----------------------------------------------------------------------------
7511       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7512       implicit real*8 (a-h,o-z)
7513       include 'DIMENSIONS'
7514       include 'sizesclu.dat'
7515       include 'COMMON.IOUNITS'
7516       include 'COMMON.CHAIN'
7517       include 'COMMON.DERIV'
7518       include 'COMMON.INTERACT'
7519       include 'COMMON.CONTACTS'
7520       include 'COMMON.TORSION'
7521       include 'COMMON.VAR'
7522       include 'COMMON.GEO'
7523       logical swap
7524       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7525      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7526       logical lprn
7527       common /kutas/ lprn
7528 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7529 C                                                                              C
7530 C      Parallel       Antiparallel                                             C
7531 C                                                                              C
7532 C          o             o                                                     C
7533 C     \   /l\           /j\   /                                                C
7534 C      \ /   \         /   \ /                                                 C
7535 C       o| o |         | o |o                                                  C
7536 C     \ j|/k\|      \  |/k\|l                                                  C
7537 C      \ /   \       \ /   \                                                   C
7538 C       o             o                                                        C
7539 C       i             i                                                        C
7540 C                                                                              C
7541 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7542 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7543 C AL 7/4/01 s1 would occur in the sixth-order moment,
7544 C           but not in a cluster cumulant
7545 #ifdef MOMENT
7546       s1=dip(1,jj,i)*dip(1,kk,k)
7547 #endif
7548       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7549       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7550       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7551       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7552       call transpose2(EUg(1,1,k),auxmat(1,1))
7553       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7554       vv(1)=pizda(1,1)-pizda(2,2)
7555       vv(2)=pizda(1,2)+pizda(2,1)
7556       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7557 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7558 #ifdef MOMENT
7559       eello6_graph2=-(s1+s2+s3+s4)
7560 #else
7561       eello6_graph2=-(s2+s3+s4)
7562 #endif
7563 c      eello6_graph2=-s3
7564       if (.not. calc_grad) return
7565 C Derivatives in gamma(i-1)
7566       if (i.gt.1) then
7567 #ifdef MOMENT
7568         s1=dipderg(1,jj,i)*dip(1,kk,k)
7569 #endif
7570         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7571         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7572         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7573         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7574 #ifdef MOMENT
7575         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7576 #else
7577         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7578 #endif
7579 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7580       endif
7581 C Derivatives in gamma(k-1)
7582 #ifdef MOMENT
7583       s1=dip(1,jj,i)*dipderg(1,kk,k)
7584 #endif
7585       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7586       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7587       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7588       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7589       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7590       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7591       vv(1)=pizda(1,1)-pizda(2,2)
7592       vv(2)=pizda(1,2)+pizda(2,1)
7593       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7594 #ifdef MOMENT
7595       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7596 #else
7597       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7598 #endif
7599 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7600 C Derivatives in gamma(j-1) or gamma(l-1)
7601       if (j.gt.1) then
7602 #ifdef MOMENT
7603         s1=dipderg(3,jj,i)*dip(1,kk,k)
7604 #endif
7605         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7606         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7607         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7608         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7609         vv(1)=pizda(1,1)-pizda(2,2)
7610         vv(2)=pizda(1,2)+pizda(2,1)
7611         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7612 #ifdef MOMENT
7613         if (swap) then
7614           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7615         else
7616           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7617         endif
7618 #endif
7619         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7620 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7621       endif
7622 C Derivatives in gamma(l-1) or gamma(j-1)
7623       if (l.gt.1) then
7624 #ifdef MOMENT
7625         s1=dip(1,jj,i)*dipderg(3,kk,k)
7626 #endif
7627         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7628         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7629         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7630         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7631         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7632         vv(1)=pizda(1,1)-pizda(2,2)
7633         vv(2)=pizda(1,2)+pizda(2,1)
7634         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7635 #ifdef MOMENT
7636         if (swap) then
7637           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7638         else
7639           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7640         endif
7641 #endif
7642         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7643 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7644       endif
7645 C Cartesian derivatives.
7646       if (lprn) then
7647         write (2,*) 'In eello6_graph2'
7648         do iii=1,2
7649           write (2,*) 'iii=',iii
7650           do kkk=1,5
7651             write (2,*) 'kkk=',kkk
7652             do jjj=1,2
7653               write (2,'(3(2f10.5),5x)')
7654      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7655             enddo
7656           enddo
7657         enddo
7658       endif
7659       do iii=1,2
7660         do kkk=1,5
7661           do lll=1,3
7662 #ifdef MOMENT
7663             if (iii.eq.1) then
7664               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7665             else
7666               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7667             endif
7668 #endif
7669             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7670      &        auxvec(1))
7671             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7672             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7673      &        auxvec(1))
7674             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7675             call transpose2(EUg(1,1,k),auxmat(1,1))
7676             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7677      &        pizda(1,1))
7678             vv(1)=pizda(1,1)-pizda(2,2)
7679             vv(2)=pizda(1,2)+pizda(2,1)
7680             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7681 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7682 #ifdef MOMENT
7683             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7684 #else
7685             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7686 #endif
7687             if (swap) then
7688               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7689             else
7690               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7691             endif
7692           enddo
7693         enddo
7694       enddo
7695       return
7696       end
7697 c----------------------------------------------------------------------------
7698       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7699       implicit real*8 (a-h,o-z)
7700       include 'DIMENSIONS'
7701       include 'sizesclu.dat'
7702       include 'COMMON.IOUNITS'
7703       include 'COMMON.CHAIN'
7704       include 'COMMON.DERIV'
7705       include 'COMMON.INTERACT'
7706       include 'COMMON.CONTACTS'
7707       include 'COMMON.TORSION'
7708       include 'COMMON.VAR'
7709       include 'COMMON.GEO'
7710       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7711       logical swap
7712 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7713 C                                                                              C
7714 C      Parallel       Antiparallel                                             C
7715 C                                                                              C
7716 C          o             o                                                     C
7717 C         /l\   /   \   /j\                                                    C
7718 C        /   \ /     \ /   \                                                   C
7719 C       /| o |o       o| o |\                                                  C
7720 C       j|/k\|  /      |/k\|l /                                                C
7721 C        /   \ /       /   \ /                                                 C
7722 C       /     o       /     o                                                  C
7723 C       i             i                                                        C
7724 C                                                                              C
7725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7726 C
7727 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7728 C           energy moment and not to the cluster cumulant.
7729       iti=itortyp(itype(i))
7730 c      if (j.lt.nres-1) then
7731       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7732         itj1=itortyp(itype(j+1))
7733       else
7734         itj1=ntortyp+1
7735       endif
7736       itk=itortyp(itype(k))
7737       itk1=itortyp(itype(k+1))
7738 c      if (l.lt.nres-1) then
7739       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7740         itl1=itortyp(itype(l+1))
7741       else
7742         itl1=ntortyp+1
7743       endif
7744 #ifdef MOMENT
7745       s1=dip(4,jj,i)*dip(4,kk,k)
7746 #endif
7747       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7748       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7749       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7750       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7751       call transpose2(EE(1,1,itk),auxmat(1,1))
7752       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7753       vv(1)=pizda(1,1)+pizda(2,2)
7754       vv(2)=pizda(2,1)-pizda(1,2)
7755       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7756 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7757 #ifdef MOMENT
7758       eello6_graph3=-(s1+s2+s3+s4)
7759 #else
7760       eello6_graph3=-(s2+s3+s4)
7761 #endif
7762 c      eello6_graph3=-s4
7763       if (.not. calc_grad) return
7764 C Derivatives in gamma(k-1)
7765       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7766       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7767       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7768       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7769 C Derivatives in gamma(l-1)
7770       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7771       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7772       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7773       vv(1)=pizda(1,1)+pizda(2,2)
7774       vv(2)=pizda(2,1)-pizda(1,2)
7775       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7776       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7777 C Cartesian derivatives.
7778       do iii=1,2
7779         do kkk=1,5
7780           do lll=1,3
7781 #ifdef MOMENT
7782             if (iii.eq.1) then
7783               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7784             else
7785               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7786             endif
7787 #endif
7788             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7789      &        auxvec(1))
7790             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7791             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7792      &        auxvec(1))
7793             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7794             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7795      &        pizda(1,1))
7796             vv(1)=pizda(1,1)+pizda(2,2)
7797             vv(2)=pizda(2,1)-pizda(1,2)
7798             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7799 #ifdef MOMENT
7800             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7801 #else
7802             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7803 #endif
7804             if (swap) then
7805               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7806             else
7807               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7808             endif
7809 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7810           enddo
7811         enddo
7812       enddo
7813       return
7814       end
7815 c----------------------------------------------------------------------------
7816       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7817       implicit real*8 (a-h,o-z)
7818       include 'DIMENSIONS'
7819       include 'sizesclu.dat'
7820       include 'COMMON.IOUNITS'
7821       include 'COMMON.CHAIN'
7822       include 'COMMON.DERIV'
7823       include 'COMMON.INTERACT'
7824       include 'COMMON.CONTACTS'
7825       include 'COMMON.TORSION'
7826       include 'COMMON.VAR'
7827       include 'COMMON.GEO'
7828       include 'COMMON.FFIELD'
7829       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7830      & auxvec1(2),auxmat1(2,2)
7831       logical swap
7832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7833 C                                                                              C
7834 C      Parallel       Antiparallel                                             C
7835 C                                                                              C
7836 C          o             o                                                     C
7837 C         /l\   /   \   /j\                                                    C
7838 C        /   \ /     \ /   \                                                   C
7839 C       /| o |o       o| o |\                                                  C
7840 C     \ j|/k\|      \  |/k\|l                                                  C
7841 C      \ /   \       \ /   \                                                   C
7842 C       o     \       o     \                                                  C
7843 C       i             i                                                        C
7844 C                                                                              C
7845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7846 C
7847 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7848 C           energy moment and not to the cluster cumulant.
7849 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7850       iti=itortyp(itype(i))
7851       itj=itortyp(itype(j))
7852 c      if (j.lt.nres-1) then
7853       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7854         itj1=itortyp(itype(j+1))
7855       else
7856         itj1=ntortyp+1
7857       endif
7858       itk=itortyp(itype(k))
7859 c      if (k.lt.nres-1) then
7860       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7861         itk1=itortyp(itype(k+1))
7862       else
7863         itk1=ntortyp+1
7864       endif
7865       itl=itortyp(itype(l))
7866       if (l.lt.nres-1) then
7867         itl1=itortyp(itype(l+1))
7868       else
7869         itl1=ntortyp+1
7870       endif
7871 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7872 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7873 cd     & ' itl',itl,' itl1',itl1
7874 #ifdef MOMENT
7875       if (imat.eq.1) then
7876         s1=dip(3,jj,i)*dip(3,kk,k)
7877       else
7878         s1=dip(2,jj,j)*dip(2,kk,l)
7879       endif
7880 #endif
7881       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7882       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7883       if (j.eq.l+1) then
7884         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7885         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7886       else
7887         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7888         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7889       endif
7890       call transpose2(EUg(1,1,k),auxmat(1,1))
7891       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7892       vv(1)=pizda(1,1)-pizda(2,2)
7893       vv(2)=pizda(2,1)+pizda(1,2)
7894       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7895 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7896 #ifdef MOMENT
7897       eello6_graph4=-(s1+s2+s3+s4)
7898 #else
7899       eello6_graph4=-(s2+s3+s4)
7900 #endif
7901       if (.not. calc_grad) return
7902 C Derivatives in gamma(i-1)
7903       if (i.gt.1) then
7904 #ifdef MOMENT
7905         if (imat.eq.1) then
7906           s1=dipderg(2,jj,i)*dip(3,kk,k)
7907         else
7908           s1=dipderg(4,jj,j)*dip(2,kk,l)
7909         endif
7910 #endif
7911         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7912         if (j.eq.l+1) then
7913           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7914           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7915         else
7916           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7917           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7918         endif
7919         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7920         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7921 cd          write (2,*) 'turn6 derivatives'
7922 #ifdef MOMENT
7923           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7924 #else
7925           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7926 #endif
7927         else
7928 #ifdef MOMENT
7929           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7930 #else
7931           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7932 #endif
7933         endif
7934       endif
7935 C Derivatives in gamma(k-1)
7936 #ifdef MOMENT
7937       if (imat.eq.1) then
7938         s1=dip(3,jj,i)*dipderg(2,kk,k)
7939       else
7940         s1=dip(2,jj,j)*dipderg(4,kk,l)
7941       endif
7942 #endif
7943       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7944       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7945       if (j.eq.l+1) then
7946         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7947         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7948       else
7949         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7950         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7951       endif
7952       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7953       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7954       vv(1)=pizda(1,1)-pizda(2,2)
7955       vv(2)=pizda(2,1)+pizda(1,2)
7956       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7957       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7958 #ifdef MOMENT
7959         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7960 #else
7961         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7962 #endif
7963       else
7964 #ifdef MOMENT
7965         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7966 #else
7967         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7968 #endif
7969       endif
7970 C Derivatives in gamma(j-1) or gamma(l-1)
7971       if (l.eq.j+1 .and. l.gt.1) then
7972         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7973         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7974         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7975         vv(1)=pizda(1,1)-pizda(2,2)
7976         vv(2)=pizda(2,1)+pizda(1,2)
7977         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7978         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7979       else if (j.gt.1) then
7980         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7981         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7982         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7983         vv(1)=pizda(1,1)-pizda(2,2)
7984         vv(2)=pizda(2,1)+pizda(1,2)
7985         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7986         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7987           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7988         else
7989           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7990         endif
7991       endif
7992 C Cartesian derivatives.
7993       do iii=1,2
7994         do kkk=1,5
7995           do lll=1,3
7996 #ifdef MOMENT
7997             if (iii.eq.1) then
7998               if (imat.eq.1) then
7999                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8000               else
8001                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8002               endif
8003             else
8004               if (imat.eq.1) then
8005                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8006               else
8007                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8008               endif
8009             endif
8010 #endif
8011             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8012      &        auxvec(1))
8013             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8014             if (j.eq.l+1) then
8015               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8016      &          b1(1,itj1),auxvec(1))
8017               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8018             else
8019               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8020      &          b1(1,itl1),auxvec(1))
8021               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8022             endif
8023             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8024      &        pizda(1,1))
8025             vv(1)=pizda(1,1)-pizda(2,2)
8026             vv(2)=pizda(2,1)+pizda(1,2)
8027             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8028             if (swap) then
8029               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8030 #ifdef MOMENT
8031                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8032      &             -(s1+s2+s4)
8033 #else
8034                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8035      &             -(s2+s4)
8036 #endif
8037                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8038               else
8039 #ifdef MOMENT
8040                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8041 #else
8042                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8043 #endif
8044                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8045               endif
8046             else
8047 #ifdef MOMENT
8048               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8049 #else
8050               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8051 #endif
8052               if (l.eq.j+1) then
8053                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8054               else
8055                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8056               endif
8057             endif
8058           enddo
8059         enddo
8060       enddo
8061       return
8062       end
8063 c----------------------------------------------------------------------------
8064       double precision function eello_turn6(i,jj,kk)
8065       implicit real*8 (a-h,o-z)
8066       include 'DIMENSIONS'
8067       include 'sizesclu.dat'
8068       include 'COMMON.IOUNITS'
8069       include 'COMMON.CHAIN'
8070       include 'COMMON.DERIV'
8071       include 'COMMON.INTERACT'
8072       include 'COMMON.CONTACTS'
8073       include 'COMMON.TORSION'
8074       include 'COMMON.VAR'
8075       include 'COMMON.GEO'
8076       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8077      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8078      &  ggg1(3),ggg2(3)
8079       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8080      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8081 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8082 C           the respective energy moment and not to the cluster cumulant.
8083       eello_turn6=0.0d0
8084       j=i+4
8085       k=i+1
8086       l=i+3
8087       iti=itortyp(itype(i))
8088       itk=itortyp(itype(k))
8089       itk1=itortyp(itype(k+1))
8090       itl=itortyp(itype(l))
8091       itj=itortyp(itype(j))
8092 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8093 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8094 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8095 cd        eello6=0.0d0
8096 cd        return
8097 cd      endif
8098 cd      write (iout,*)
8099 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8100 cd     &   ' and',k,l
8101 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8102       do iii=1,2
8103         do kkk=1,5
8104           do lll=1,3
8105             derx_turn(lll,kkk,iii)=0.0d0
8106           enddo
8107         enddo
8108       enddo
8109 cd      eij=1.0d0
8110 cd      ekl=1.0d0
8111 cd      ekont=1.0d0
8112       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8113 cd      eello6_5=0.0d0
8114 cd      write (2,*) 'eello6_5',eello6_5
8115 #ifdef MOMENT
8116       call transpose2(AEA(1,1,1),auxmat(1,1))
8117       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8118       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8119       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8120 #else
8121       s1 = 0.0d0
8122 #endif
8123       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8124       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8125       s2 = scalar2(b1(1,itk),vtemp1(1))
8126 #ifdef MOMENT
8127       call transpose2(AEA(1,1,2),atemp(1,1))
8128       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8129       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8130       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8131 #else
8132       s8=0.0d0
8133 #endif
8134       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8135       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8136       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8137 #ifdef MOMENT
8138       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8139       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8140       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8141       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8142       ss13 = scalar2(b1(1,itk),vtemp4(1))
8143       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8144 #else
8145       s13=0.0d0
8146 #endif
8147 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8148 c      s1=0.0d0
8149 c      s2=0.0d0
8150 c      s8=0.0d0
8151 c      s12=0.0d0
8152 c      s13=0.0d0
8153       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8154       if (calc_grad) then
8155 C Derivatives in gamma(i+2)
8156 #ifdef MOMENT
8157       call transpose2(AEA(1,1,1),auxmatd(1,1))
8158       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8159       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8160       call transpose2(AEAderg(1,1,2),atempd(1,1))
8161       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8162       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8163 #else
8164       s8d=0.0d0
8165 #endif
8166       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8167       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8168       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8169 c      s1d=0.0d0
8170 c      s2d=0.0d0
8171 c      s8d=0.0d0
8172 c      s12d=0.0d0
8173 c      s13d=0.0d0
8174       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8175 C Derivatives in gamma(i+3)
8176 #ifdef MOMENT
8177       call transpose2(AEA(1,1,1),auxmatd(1,1))
8178       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8179       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8180       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8181 #else
8182       s1d=0.0d0
8183 #endif
8184       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8185       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8186       s2d = scalar2(b1(1,itk),vtemp1d(1))
8187 #ifdef MOMENT
8188       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8189       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8190 #endif
8191       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8192 #ifdef MOMENT
8193       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8194       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8195       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8196 #else
8197       s13d=0.0d0
8198 #endif
8199 c      s1d=0.0d0
8200 c      s2d=0.0d0
8201 c      s8d=0.0d0
8202 c      s12d=0.0d0
8203 c      s13d=0.0d0
8204 #ifdef MOMENT
8205       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8206      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8207 #else
8208       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8209      &               -0.5d0*ekont*(s2d+s12d)
8210 #endif
8211 C Derivatives in gamma(i+4)
8212       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8213       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8214       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8215 #ifdef MOMENT
8216       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8217       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8218       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8219 #else
8220       s13d = 0.0d0
8221 #endif
8222 c      s1d=0.0d0
8223 c      s2d=0.0d0
8224 c      s8d=0.0d0
8225 C      s12d=0.0d0
8226 c      s13d=0.0d0
8227 #ifdef MOMENT
8228       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8229 #else
8230       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8231 #endif
8232 C Derivatives in gamma(i+5)
8233 #ifdef MOMENT
8234       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8235       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8236       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8237 #else
8238       s1d = 0.0d0
8239 #endif
8240       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8241       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8242       s2d = scalar2(b1(1,itk),vtemp1d(1))
8243 #ifdef MOMENT
8244       call transpose2(AEA(1,1,2),atempd(1,1))
8245       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8246       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8247 #else
8248       s8d = 0.0d0
8249 #endif
8250       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8251       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8252 #ifdef MOMENT
8253       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8254       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8255       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8256 #else
8257       s13d = 0.0d0
8258 #endif
8259 c      s1d=0.0d0
8260 c      s2d=0.0d0
8261 c      s8d=0.0d0
8262 c      s12d=0.0d0
8263 c      s13d=0.0d0
8264 #ifdef MOMENT
8265       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8266      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8267 #else
8268       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8269      &               -0.5d0*ekont*(s2d+s12d)
8270 #endif
8271 C Cartesian derivatives
8272       do iii=1,2
8273         do kkk=1,5
8274           do lll=1,3
8275 #ifdef MOMENT
8276             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8277             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8278             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8279 #else
8280             s1d = 0.0d0
8281 #endif
8282             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8283             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8284      &          vtemp1d(1))
8285             s2d = scalar2(b1(1,itk),vtemp1d(1))
8286 #ifdef MOMENT
8287             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8288             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8289             s8d = -(atempd(1,1)+atempd(2,2))*
8290      &           scalar2(cc(1,1,itl),vtemp2(1))
8291 #else
8292             s8d = 0.0d0
8293 #endif
8294             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8295      &           auxmatd(1,1))
8296             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8297             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8298 c      s1d=0.0d0
8299 c      s2d=0.0d0
8300 c      s8d=0.0d0
8301 c      s12d=0.0d0
8302 c      s13d=0.0d0
8303 #ifdef MOMENT
8304             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8305      &        - 0.5d0*(s1d+s2d)
8306 #else
8307             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8308      &        - 0.5d0*s2d
8309 #endif
8310 #ifdef MOMENT
8311             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8312      &        - 0.5d0*(s8d+s12d)
8313 #else
8314             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8315      &        - 0.5d0*s12d
8316 #endif
8317           enddo
8318         enddo
8319       enddo
8320 #ifdef MOMENT
8321       do kkk=1,5
8322         do lll=1,3
8323           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8324      &      achuj_tempd(1,1))
8325           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8326           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8327           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8328           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8329           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8330      &      vtemp4d(1))
8331           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8332           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8333           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8334         enddo
8335       enddo
8336 #endif
8337 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8338 cd     &  16*eel_turn6_num
8339 cd      goto 1112
8340       if (j.lt.nres-1) then
8341         j1=j+1
8342         j2=j-1
8343       else
8344         j1=j-1
8345         j2=j-2
8346       endif
8347       if (l.lt.nres-1) then
8348         l1=l+1
8349         l2=l-1
8350       else
8351         l1=l-1
8352         l2=l-2
8353       endif
8354       do ll=1,3
8355         ggg1(ll)=eel_turn6*g_contij(ll,1)
8356         ggg2(ll)=eel_turn6*g_contij(ll,2)
8357         ghalf=0.5d0*ggg1(ll)
8358 cd        ghalf=0.0d0
8359         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8360      &    +ekont*derx_turn(ll,2,1)
8361         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8362         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8363      &    +ekont*derx_turn(ll,4,1)
8364         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8365         ghalf=0.5d0*ggg2(ll)
8366 cd        ghalf=0.0d0
8367         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8368      &    +ekont*derx_turn(ll,2,2)
8369         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8370         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8371      &    +ekont*derx_turn(ll,4,2)
8372         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8373       enddo
8374 cd      goto 1112
8375       do m=i+1,j-1
8376         do ll=1,3
8377           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8378         enddo
8379       enddo
8380       do m=k+1,l-1
8381         do ll=1,3
8382           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8383         enddo
8384       enddo
8385 1112  continue
8386       do m=i+2,j2
8387         do ll=1,3
8388           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8389         enddo
8390       enddo
8391       do m=k+2,l2
8392         do ll=1,3
8393           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8394         enddo
8395       enddo
8396 cd      do iii=1,nres-3
8397 cd        write (2,*) iii,g_corr6_loc(iii)
8398 cd      enddo
8399       endif
8400       eello_turn6=ekont*eel_turn6
8401 cd      write (2,*) 'ekont',ekont
8402 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8403       return
8404       end
8405 crc-------------------------------------------------
8406       SUBROUTINE MATVEC2(A1,V1,V2)
8407       implicit real*8 (a-h,o-z)
8408       include 'DIMENSIONS'
8409       DIMENSION A1(2,2),V1(2),V2(2)
8410 c      DO 1 I=1,2
8411 c        VI=0.0
8412 c        DO 3 K=1,2
8413 c    3     VI=VI+A1(I,K)*V1(K)
8414 c        Vaux(I)=VI
8415 c    1 CONTINUE
8416
8417       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8418       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8419
8420       v2(1)=vaux1
8421       v2(2)=vaux2
8422       END
8423 C---------------------------------------
8424       SUBROUTINE MATMAT2(A1,A2,A3)
8425       implicit real*8 (a-h,o-z)
8426       include 'DIMENSIONS'
8427       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8428 c      DIMENSION AI3(2,2)
8429 c        DO  J=1,2
8430 c          A3IJ=0.0
8431 c          DO K=1,2
8432 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8433 c          enddo
8434 c          A3(I,J)=A3IJ
8435 c       enddo
8436 c      enddo
8437
8438       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8439       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8440       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8441       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8442
8443       A3(1,1)=AI3_11
8444       A3(2,1)=AI3_21
8445       A3(1,2)=AI3_12
8446       A3(2,2)=AI3_22
8447       END
8448
8449 c-------------------------------------------------------------------------
8450       double precision function scalar2(u,v)
8451       implicit none
8452       double precision u(2),v(2)
8453       double precision sc
8454       integer i
8455       scalar2=u(1)*v(1)+u(2)*v(2)
8456       return
8457       end
8458
8459 C-----------------------------------------------------------------------------
8460
8461       subroutine transpose2(a,at)
8462       implicit none
8463       double precision a(2,2),at(2,2)
8464       at(1,1)=a(1,1)
8465       at(1,2)=a(2,1)
8466       at(2,1)=a(1,2)
8467       at(2,2)=a(2,2)
8468       return
8469       end
8470 c--------------------------------------------------------------------------
8471       subroutine transpose(n,a,at)
8472       implicit none
8473       integer n,i,j
8474       double precision a(n,n),at(n,n)
8475       do i=1,n
8476         do j=1,n
8477           at(j,i)=a(i,j)
8478         enddo
8479       enddo
8480       return
8481       end
8482 C---------------------------------------------------------------------------
8483       subroutine prodmat3(a1,a2,kk,transp,prod)
8484       implicit none
8485       integer i,j
8486       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8487       logical transp
8488 crc      double precision auxmat(2,2),prod_(2,2)
8489
8490       if (transp) then
8491 crc        call transpose2(kk(1,1),auxmat(1,1))
8492 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8493 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8494
8495            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8496      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8497            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8498      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8499            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8500      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8501            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8502      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8503
8504       else
8505 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8506 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8507
8508            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8509      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8510            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8511      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8512            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8513      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8514            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8515      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8516
8517       endif
8518 c      call transpose2(a2(1,1),a2t(1,1))
8519
8520 crc      print *,transp
8521 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8522 crc      print *,((prod(i,j),i=1,2),j=1,2)
8523
8524       return
8525       end
8526 C-----------------------------------------------------------------------------
8527       double precision function scalar(u,v)
8528       implicit none
8529       double precision u(3),v(3)
8530       double precision sc
8531       integer i
8532       sc=0.0d0
8533       do i=1,3
8534         sc=sc+u(i)*v(i)
8535       enddo
8536       scalar=sc
8537       return
8538       end
8539 C-----------------------------------------------------------------------
8540       double precision function sscale(r)
8541       double precision r,gamm
8542       include "COMMON.SPLITELE"
8543       if(r.lt.r_cut-rlamb) then
8544         sscale=1.0d0
8545       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8546         gamm=(r-(r_cut-rlamb))/rlamb
8547         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8548       else
8549         sscale=0d0
8550       endif
8551       return
8552       end
8553 C-----------------------------------------------------------------------
8554 C-----------------------------------------------------------------------
8555       double precision function sscagrad(r)
8556       double precision r,gamm
8557       include "COMMON.SPLITELE"
8558       if(r.lt.r_cut-rlamb) then
8559         sscagrad=0.0d0
8560       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8561         gamm=(r-(r_cut-rlamb))/rlamb
8562         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8563       else
8564         sscagrad=0.0d0
8565       endif
8566       return
8567       end
8568 C-----------------------------------------------------------------------
8569 C first for shielding is setting of function of side-chains
8570        subroutine set_shield_fac2
8571       implicit real*8 (a-h,o-z)
8572       include 'DIMENSIONS'
8573       include 'COMMON.CHAIN'
8574       include 'COMMON.DERIV'
8575       include 'COMMON.IOUNITS'
8576       include 'COMMON.SHIELD'
8577       include 'COMMON.INTERACT'
8578 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8579       double precision div77_81/0.974996043d0/,
8580      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8581
8582 C the vector between center of side_chain and peptide group
8583        double precision pep_side(3),long,side_calf(3),
8584      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8585      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8586 C the line belowe needs to be changed for FGPROC>1
8587       do i=1,nres-1
8588       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8589       ishield_list(i)=0
8590 Cif there two consequtive dummy atoms there is no peptide group between them
8591 C the line below has to be changed for FGPROC>1
8592       VolumeTotal=0.0
8593       do k=1,nres
8594        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8595        dist_pep_side=0.0
8596        dist_side_calf=0.0
8597        do j=1,3
8598 C first lets set vector conecting the ithe side-chain with kth side-chain
8599       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8600 C      pep_side(j)=2.0d0
8601 C and vector conecting the side-chain with its proper calfa
8602       side_calf(j)=c(j,k+nres)-c(j,k)
8603 C      side_calf(j)=2.0d0
8604       pept_group(j)=c(j,i)-c(j,i+1)
8605 C lets have their lenght
8606       dist_pep_side=pep_side(j)**2+dist_pep_side
8607       dist_side_calf=dist_side_calf+side_calf(j)**2
8608       dist_pept_group=dist_pept_group+pept_group(j)**2
8609       enddo
8610        dist_pep_side=dsqrt(dist_pep_side)
8611        dist_pept_group=dsqrt(dist_pept_group)
8612        dist_side_calf=dsqrt(dist_side_calf)
8613       do j=1,3
8614         pep_side_norm(j)=pep_side(j)/dist_pep_side
8615         side_calf_norm(j)=dist_side_calf
8616       enddo
8617 C now sscale fraction
8618        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8619 C       print *,buff_shield,"buff"
8620 C now sscale
8621         if (sh_frac_dist.le.0.0) cycle
8622 C If we reach here it means that this side chain reaches the shielding sphere
8623 C Lets add him to the list for gradient
8624         ishield_list(i)=ishield_list(i)+1
8625 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8626 C this list is essential otherwise problem would be O3
8627         shield_list(ishield_list(i),i)=k
8628 C Lets have the sscale value
8629         if (sh_frac_dist.gt.1.0) then
8630          scale_fac_dist=1.0d0
8631          do j=1,3
8632          sh_frac_dist_grad(j)=0.0d0
8633          enddo
8634         else
8635          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8636      &                   *(2.0d0*sh_frac_dist-3.0d0)
8637          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8638      &                  /dist_pep_side/buff_shield*0.5d0
8639 C remember for the final gradient multiply sh_frac_dist_grad(j)
8640 C for side_chain by factor -2 !
8641          do j=1,3
8642          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8643 C         sh_frac_dist_grad(j)=0.0d0
8644 C         scale_fac_dist=1.0d0
8645 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8646 C     &                    sh_frac_dist_grad(j)
8647          enddo
8648         endif
8649 C this is what is now we have the distance scaling now volume...
8650       short=short_r_sidechain(itype(k))
8651       long=long_r_sidechain(itype(k))
8652       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8653       sinthet=short/dist_pep_side*costhet
8654 C now costhet_grad
8655 C       costhet=0.6d0
8656 C       sinthet=0.8
8657        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8658 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8659 C     &             -short/dist_pep_side**2/costhet)
8660 C       costhet_fac=0.0d0
8661        do j=1,3
8662          costhet_grad(j)=costhet_fac*pep_side(j)
8663        enddo
8664 C remember for the final gradient multiply costhet_grad(j)
8665 C for side_chain by factor -2 !
8666 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8667 C pep_side0pept_group is vector multiplication
8668       pep_side0pept_group=0.0d0
8669       do j=1,3
8670       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8671       enddo
8672       cosalfa=(pep_side0pept_group/
8673      & (dist_pep_side*dist_side_calf))
8674       fac_alfa_sin=1.0d0-cosalfa**2
8675       fac_alfa_sin=dsqrt(fac_alfa_sin)
8676       rkprim=fac_alfa_sin*(long-short)+short
8677 C      rkprim=short
8678
8679 C now costhet_grad
8680        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8681 C       cosphi=0.6
8682        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8683        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8684      &      dist_pep_side**2)
8685 C       sinphi=0.8
8686        do j=1,3
8687          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8688      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8689      &*(long-short)/fac_alfa_sin*cosalfa/
8690      &((dist_pep_side*dist_side_calf))*
8691      &((side_calf(j))-cosalfa*
8692      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8693 C       cosphi_grad_long(j)=0.0d0
8694         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8695      &*(long-short)/fac_alfa_sin*cosalfa
8696      &/((dist_pep_side*dist_side_calf))*
8697      &(pep_side(j)-
8698      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8699 C       cosphi_grad_loc(j)=0.0d0
8700        enddo
8701 C      print *,sinphi,sinthet
8702       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8703      &                    /VSolvSphere_div
8704 C     &                    *wshield
8705 C now the gradient...
8706       do j=1,3
8707       grad_shield(j,i)=grad_shield(j,i)
8708 C gradient po skalowaniu
8709      &                +(sh_frac_dist_grad(j)*VofOverlap
8710 C  gradient po costhet
8711      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8712      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8713      &       sinphi/sinthet*costhet*costhet_grad(j)
8714      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8715      & )*wshield
8716 C grad_shield_side is Cbeta sidechain gradient
8717       grad_shield_side(j,ishield_list(i),i)=
8718      &        (sh_frac_dist_grad(j)*-2.0d0
8719      &        *VofOverlap
8720      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8721      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8722      &       sinphi/sinthet*costhet*costhet_grad(j)
8723      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8724      &       )*wshield
8725
8726        grad_shield_loc(j,ishield_list(i),i)=
8727      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8728      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8729      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8730      &        ))
8731      &        *wshield
8732       enddo
8733       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8734       enddo
8735       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8736 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8737       enddo
8738       return
8739       end
8740 C first for shielding is setting of function of side-chains
8741        subroutine set_shield_fac
8742       implicit real*8 (a-h,o-z)
8743       include 'DIMENSIONS'
8744       include 'COMMON.CHAIN'
8745       include 'COMMON.DERIV'
8746       include 'COMMON.IOUNITS'
8747       include 'COMMON.SHIELD'
8748       include 'COMMON.INTERACT'
8749 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8750       double precision div77_81/0.974996043d0/,
8751      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8752
8753 C the vector between center of side_chain and peptide group
8754        double precision pep_side(3),long,side_calf(3),
8755      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8756      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8757 C the line belowe needs to be changed for FGPROC>1
8758       do i=1,nres-1
8759       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8760       ishield_list(i)=0
8761 Cif there two consequtive dummy atoms there is no peptide group between them
8762 C the line below has to be changed for FGPROC>1
8763       VolumeTotal=0.0
8764       do k=1,nres
8765        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8766        dist_pep_side=0.0
8767        dist_side_calf=0.0
8768        do j=1,3
8769 C first lets set vector conecting the ithe side-chain with kth side-chain
8770       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8771 C      pep_side(j)=2.0d0
8772 C and vector conecting the side-chain with its proper calfa
8773       side_calf(j)=c(j,k+nres)-c(j,k)
8774 C      side_calf(j)=2.0d0
8775       pept_group(j)=c(j,i)-c(j,i+1)
8776 C lets have their lenght
8777       dist_pep_side=pep_side(j)**2+dist_pep_side
8778       dist_side_calf=dist_side_calf+side_calf(j)**2
8779       dist_pept_group=dist_pept_group+pept_group(j)**2
8780       enddo
8781        dist_pep_side=dsqrt(dist_pep_side)
8782        dist_pept_group=dsqrt(dist_pept_group)
8783        dist_side_calf=dsqrt(dist_side_calf)
8784       do j=1,3
8785         pep_side_norm(j)=pep_side(j)/dist_pep_side
8786         side_calf_norm(j)=dist_side_calf
8787       enddo
8788 C now sscale fraction
8789        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8790 C       print *,buff_shield,"buff"
8791 C now sscale
8792         if (sh_frac_dist.le.0.0) cycle
8793 C If we reach here it means that this side chain reaches the shielding sphere
8794 C Lets add him to the list for gradient
8795         ishield_list(i)=ishield_list(i)+1
8796 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8797 C this list is essential otherwise problem would be O3
8798         shield_list(ishield_list(i),i)=k
8799 C Lets have the sscale value
8800         if (sh_frac_dist.gt.1.0) then
8801          scale_fac_dist=1.0d0
8802          do j=1,3
8803          sh_frac_dist_grad(j)=0.0d0
8804          enddo
8805         else
8806          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8807      &                   *(2.0*sh_frac_dist-3.0d0)
8808          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8809      &                  /dist_pep_side/buff_shield*0.5
8810 C remember for the final gradient multiply sh_frac_dist_grad(j)
8811 C for side_chain by factor -2 !
8812          do j=1,3
8813          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8814 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8815 C     &                    sh_frac_dist_grad(j)
8816          enddo
8817         endif
8818 C        if ((i.eq.3).and.(k.eq.2)) then
8819 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8820 C     & ,"TU"
8821 C        endif
8822
8823 C this is what is now we have the distance scaling now volume...
8824       short=short_r_sidechain(itype(k))
8825       long=long_r_sidechain(itype(k))
8826       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8827 C now costhet_grad
8828 C       costhet=0.0d0
8829        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8830 C       costhet_fac=0.0d0
8831        do j=1,3
8832          costhet_grad(j)=costhet_fac*pep_side(j)
8833        enddo
8834 C remember for the final gradient multiply costhet_grad(j)
8835 C for side_chain by factor -2 !
8836 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8837 C pep_side0pept_group is vector multiplication
8838       pep_side0pept_group=0.0
8839       do j=1,3
8840       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8841       enddo
8842       cosalfa=(pep_side0pept_group/
8843      & (dist_pep_side*dist_side_calf))
8844       fac_alfa_sin=1.0-cosalfa**2
8845       fac_alfa_sin=dsqrt(fac_alfa_sin)
8846       rkprim=fac_alfa_sin*(long-short)+short
8847 C now costhet_grad
8848        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8849        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8850
8851        do j=1,3
8852          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8853      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8854      &*(long-short)/fac_alfa_sin*cosalfa/
8855      &((dist_pep_side*dist_side_calf))*
8856      &((side_calf(j))-cosalfa*
8857      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8858
8859         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8860      &*(long-short)/fac_alfa_sin*cosalfa
8861      &/((dist_pep_side*dist_side_calf))*
8862      &(pep_side(j)-
8863      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8864        enddo
8865
8866       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8867      &                    /VSolvSphere_div
8868      &                    *wshield
8869 C now the gradient...
8870 C grad_shield is gradient of Calfa for peptide groups
8871 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8872 C     &               costhet,cosphi
8873 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8874 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8875       do j=1,3
8876       grad_shield(j,i)=grad_shield(j,i)
8877 C gradient po skalowaniu
8878      &                +(sh_frac_dist_grad(j)
8879 C  gradient po costhet
8880      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8881      &-scale_fac_dist*(cosphi_grad_long(j))
8882      &/(1.0-cosphi) )*div77_81
8883      &*VofOverlap
8884 C grad_shield_side is Cbeta sidechain gradient
8885       grad_shield_side(j,ishield_list(i),i)=
8886      &        (sh_frac_dist_grad(j)*-2.0d0
8887      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8888      &       +scale_fac_dist*(cosphi_grad_long(j))
8889      &        *2.0d0/(1.0-cosphi))
8890      &        *div77_81*VofOverlap
8891
8892        grad_shield_loc(j,ishield_list(i),i)=
8893      &   scale_fac_dist*cosphi_grad_loc(j)
8894      &        *2.0d0/(1.0-cosphi)
8895      &        *div77_81*VofOverlap
8896       enddo
8897       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8898       enddo
8899       fac_shield(i)=VolumeTotal*div77_81+div4_81
8900 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8901       enddo
8902       return
8903       end
8904 C--------------------------------------------------------------------------
8905 C-----------------------------------------------------------------------
8906       double precision function sscalelip(r)
8907       double precision r,gamm
8908       include "COMMON.SPLITELE"
8909 C      if(r.lt.r_cut-rlamb) then
8910 C        sscale=1.0d0
8911 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8912 C        gamm=(r-(r_cut-rlamb))/rlamb
8913         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8914 C      else
8915 C        sscale=0d0
8916 C      endif
8917       return
8918       end
8919 C-----------------------------------------------------------------------
8920       double precision function sscagradlip(r)
8921       double precision r,gamm
8922       include "COMMON.SPLITELE"
8923 C     if(r.lt.r_cut-rlamb) then
8924 C        sscagrad=0.0d0
8925 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8926 C        gamm=(r-(r_cut-rlamb))/rlamb
8927         sscagradlip=r*(6*r-6.0d0)
8928 C      else
8929 C        sscagrad=0.0d0
8930 C      endif
8931       return
8932       end
8933
8934 C-----------------------------------------------------------------------
8935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8936       subroutine Eliptransfer(eliptran)
8937       implicit real*8 (a-h,o-z)
8938       include 'DIMENSIONS'
8939       include 'COMMON.GEO'
8940       include 'COMMON.VAR'
8941       include 'COMMON.LOCAL'
8942       include 'COMMON.CHAIN'
8943       include 'COMMON.DERIV'
8944       include 'COMMON.INTERACT'
8945       include 'COMMON.IOUNITS'
8946       include 'COMMON.CALC'
8947       include 'COMMON.CONTROL'
8948       include 'COMMON.SPLITELE'
8949       include 'COMMON.SBRIDGE'
8950 C this is done by Adasko
8951 C      print *,"wchodze"
8952 C structure of box:
8953 C      water
8954 C--bordliptop-- buffore starts
8955 C--bufliptop--- here true lipid starts
8956 C      lipid
8957 C--buflipbot--- lipid ends buffore starts
8958 C--bordlipbot--buffore ends
8959       eliptran=0.0
8960       write(iout,*) "I am in?"
8961       do i=1,nres
8962 C       do i=1,1
8963         if (itype(i).eq.ntyp1) cycle
8964
8965         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8966         if (positi.le.0) positi=positi+boxzsize
8967 C        print *,i
8968 C first for peptide groups
8969 c for each residue check if it is in lipid or lipid water border area
8970        if ((positi.gt.bordlipbot)
8971      &.and.(positi.lt.bordliptop)) then
8972 C the energy transfer exist
8973         if (positi.lt.buflipbot) then
8974 C what fraction I am in
8975          fracinbuf=1.0d0-
8976      &        ((positi-bordlipbot)/lipbufthick)
8977 C lipbufthick is thickenes of lipid buffore
8978          sslip=sscalelip(fracinbuf)
8979          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8980          eliptran=eliptran+sslip*pepliptran
8981          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8982          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8983 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8984         elseif (positi.gt.bufliptop) then
8985          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8986          sslip=sscalelip(fracinbuf)
8987          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8988          eliptran=eliptran+sslip*pepliptran
8989          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8990          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8991 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8992 C          print *, "doing sscalefor top part"
8993 C         print *,i,sslip,fracinbuf,ssgradlip
8994         else
8995          eliptran=eliptran+pepliptran
8996 C         print *,"I am in true lipid"
8997         endif
8998 C       else
8999 C       eliptran=elpitran+0.0 ! I am in water
9000        endif
9001        enddo
9002 C       print *, "nic nie bylo w lipidzie?"
9003 C now multiply all by the peptide group transfer factor
9004 C       eliptran=eliptran*pepliptran
9005 C now the same for side chains
9006 CV       do i=1,1
9007        do i=1,nres
9008         if (itype(i).eq.ntyp1) cycle
9009         positi=(mod(c(3,i+nres),boxzsize))
9010         if (positi.le.0) positi=positi+boxzsize
9011 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9012 c for each residue check if it is in lipid or lipid water border area
9013 C       respos=mod(c(3,i+nres),boxzsize)
9014 C       print *,positi,bordlipbot,buflipbot
9015        if ((positi.gt.bordlipbot)
9016      & .and.(positi.lt.bordliptop)) then
9017 C the energy transfer exist
9018         if (positi.lt.buflipbot) then
9019          fracinbuf=1.0d0-
9020      &     ((positi-bordlipbot)/lipbufthick)
9021 C lipbufthick is thickenes of lipid buffore
9022          sslip=sscalelip(fracinbuf)
9023          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9024          eliptran=eliptran+sslip*liptranene(itype(i))
9025          gliptranx(3,i)=gliptranx(3,i)
9026      &+ssgradlip*liptranene(itype(i))
9027          gliptranc(3,i-1)= gliptranc(3,i-1)
9028      &+ssgradlip*liptranene(itype(i))
9029 C         print *,"doing sccale for lower part"
9030         elseif (positi.gt.bufliptop) then
9031          fracinbuf=1.0d0-
9032      &((bordliptop-positi)/lipbufthick)
9033          sslip=sscalelip(fracinbuf)
9034          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9035          eliptran=eliptran+sslip*liptranene(itype(i))
9036          gliptranx(3,i)=gliptranx(3,i)
9037      &+ssgradlip*liptranene(itype(i))
9038          gliptranc(3,i-1)= gliptranc(3,i-1)
9039      &+ssgradlip*liptranene(itype(i))
9040 C          print *, "doing sscalefor top part",sslip,fracinbuf
9041         else
9042          eliptran=eliptran+liptranene(itype(i))
9043 C         print *,"I am in true lipid"
9044         endif
9045         endif ! if in lipid or buffor
9046 C       else
9047 C       eliptran=elpitran+0.0 ! I am in water
9048        enddo
9049        return
9050        end
9051 C-------------------------------------------------------------------------------------