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
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11
  12       include 'COMMON.IOUNITS'
  13       double precision energia(0:max_ene),energia1(0:max_ene+1)
  14       include 'COMMON.FFIELD'
  15       include 'COMMON.DERIV'
  16       include 'COMMON.INTERACT'
  17       include 'COMMON.SBRIDGE'
  18       include 'COMMON.CHAIN'
  19       include 'COMMON.SHIELD'
  20       include 'COMMON.CONTROL'
  21       include 'COMMON.TORCNSTR'
  22       double precision fact(6)
  23 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  24 c      call flush(iout)
  25 cd    print *,'nnt=',nnt,' nct=',nct
  26 C
  27 C Compute the side-chain and electrostatic interaction energy
  28 C
  29       goto (101,102,103,104,105) ipot
  30 C Lennard-Jones potential.
  31   101 call elj(evdw,evdw_t)
  32 cd    print '(a)','Exit ELJ'
  33       goto 106
  34 C Lennard-Jones-Kihara potential (shifted).
  35   102 call eljk(evdw,evdw_t)
  36       goto 106
  37 C Berne-Pechukas potential (dilated LJ, angular dependence).
  38   103 call ebp(evdw,evdw_t)
  39       goto 106
  40 C Gay-Berne potential (shifted LJ, angular dependence).
  41   104 call egb(evdw,evdw_t)
  42       goto 106
  43 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  44   105 call egbv(evdw,evdw_t)
  45 C
  46 C Calculate electrostatic (H-bonding) energy of the main chain.
  47 C
  48   106 continue
  49 c      write (iout,*) "Sidechain"
  50       call flush(iout)
  51       call vec_and_deriv
  52       if (shield_mode.eq.1) then
  53        call set_shield_fac
  54       else if  (shield_mode.eq.2) then
  55        call set_shield_fac2
  56       endif
  57       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  58 c            write(iout,*) 'po eelec'
  59 c      call flush(iout)
  60
  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
  69       call ebond(estr)
  70 C       write (iout,*) "estr",estr
  71 C
  72 C Calculate the disulfide-bridge and other energy and the contributions
  73 C from other distance constraints.
  74 cd    print *,'Calling EHPB'
  75       call edis(ehpb)
  76 cd    print *,'EHPB exitted succesfully.'
  77 C
  78 C Calculate the virtual-bond-angle energy.
  79 C
  80 C      print *,'Bend energy finished.'
  81       if (wang.gt.0d0) then
  82        if (tor_mode.eq.0) then
  83          call ebend(ebe)
  84        else
  85 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  86 C energy function
  87          call ebend_kcc(ebe)
  88        endif
  89       else
  90         ebe=0.0d0
  91       endif
  92       ethetacnstr=0.0d0
  93       if (with_theta_constr) call etheta_constr(ethetacnstr)
  94 c      call ebend(ebe,ethetacnstr)
  95 cd    print *,'Bend energy finished.'
  96 C
  97 C Calculate the SC local energy.
  98 C
  99       call esc(escloc)
 100 C       print *,'SCLOC energy finished.'
 101 C
 102 C Calculate the virtual-bond torsional energy.
 103 C
 104       if (wtor.gt.0.0d0) then
 105          if (tor_mode.eq.0) then
 106            call etor(etors,fact(1))
 107          else
 108 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 109 C energy function
 110            call etor_kcc(etors,fact(1))
 111          endif
 112       else
 113         etors=0.0d0
 114       endif
 115       edihcnstr=0.0d0
 116       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 117 c      print *,"Processor",myrank," computed Utor"
 118 C
 119 C 6/23/01 Calculate double-torsional energy
 120 C
 121       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 122         call etor_d(etors_d,fact(2))
 123       else
 124         etors_d=0
 125       endif
 126 c      print *,"Processor",myrank," computed Utord"
 127 C
 128       call eback_sc_corr(esccor)
 129
 130       if (wliptran.gt.0) then
 131         call Eliptransfer(eliptran)
 132       endif
 133
 134 C
 135 C 12/1/95 Multi-body terms
 136 C
 137       n_corr=0
 138       n_corr1=0
 139       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 140      &    .or. wturn6.gt.0.0d0) then
 141 c         write(iout,*)"calling multibody_eello"
 142          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 143 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 144 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 145       else
 146          ecorr=0.0d0
 147          ecorr5=0.0d0
 148          ecorr6=0.0d0
 149          eturn6=0.0d0
 150       endif
 151       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 152 c         write (iout,*) "Calling multibody_hbond"
 153          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 154       endif
 155 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 156 #ifdef SPLITELE
 157       if (shield_mode.gt.0) then
 158       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 159      & +welec*fact(1)*ees
 160      & +fact(1)*wvdwpp*evdw1
 161      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 162      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 163      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 164      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 165      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 166      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 167      & +wliptran*eliptran
 168       else
 169       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 170      & +wvdwpp*evdw1
 171      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 172      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 173      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 174      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 175      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 176      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 177      & +wliptran*eliptran
 178       endif
 179 #else
 180       if (shield_mode.gt.0) then
 181       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 182      & +welec*fact(1)*(ees+evdw1)
 183      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 184      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 185      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 186      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 187      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 188      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 189      & +wliptran*eliptran
 190       else
 191       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 192      & +welec*fact(1)*(ees+evdw1)
 193      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 194      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 195      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 196      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 197      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 198      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 199      & +wliptran*eliptran
 200       endif
 201 #endif
 202       energia(0)=etot
 203       energia(1)=evdw
 204 #ifdef SCP14
 205       energia(2)=evdw2-evdw2_14
 206       energia(17)=evdw2_14
 207 #else
 208       energia(2)=evdw2
 209       energia(17)=0.0d0
 210 #endif
 211 #ifdef SPLITELE
 212       energia(3)=ees
 213       energia(16)=evdw1
 214 #else
 215       energia(3)=ees+evdw1
 216       energia(16)=0.0d0
 217 #endif
 218       energia(4)=ecorr
 219       energia(5)=ecorr5
 220       energia(6)=ecorr6
 221       energia(7)=eel_loc
 222       energia(8)=eello_turn3
 223       energia(9)=eello_turn4
 224       energia(10)=eturn6
 225       energia(11)=ebe
 226       energia(12)=escloc
 227       energia(13)=etors
 228       energia(14)=etors_d
 229       energia(15)=ehpb
 230       energia(18)=estr
 231       energia(19)=esccor
 232       energia(20)=edihcnstr
 233       energia(21)=evdw_t
 234       energia(24)=ethetacnstr
 235       energia(22)=eliptran
 236 c detecting NaNQ
 237 #ifdef ISNAN
 238 #ifdef AIX
 239       if (isnan(etot).ne.0) energia(0)=1.0d+99
 240 #else
 241       if (isnan(etot)) energia(0)=1.0d+99
 242 #endif
 243 #else
 244       i=0
 245 #ifdef WINPGI
 246       idumm=proc_proc(etot,i)
 247 #else
 248       call proc_proc(etot,i)
 249 #endif
 250       if(i.eq.1)energia(0)=1.0d+99
 251 #endif
 252 #ifdef MPL
 253 c     endif
 254 #endif
 255 #ifdef DEBUG
 256       call enerprint(energia,fact)
 257 #endif
 258       if (calc_grad) then
 259 C
 260 C Sum up the components of the Cartesian gradient.
 261 C
 262 #ifdef SPLITELE
 263       do i=1,nct
 264         do j=1,3
 265       if (shield_mode.eq.0) then
 266           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 267      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 268      &                wbond*gradb(j,i)+
 269      &                wstrain*ghpbc(j,i)+
 270      &                wcorr*fact(3)*gradcorr(j,i)+
 271      &                wel_loc*fact(2)*gel_loc(j,i)+
 272      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 273      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 274      &                wcorr5*fact(4)*gradcorr5(j,i)+
 275      &                wcorr6*fact(5)*gradcorr6(j,i)+
 276      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 277      &                wsccor*fact(2)*gsccorc(j,i)
 278      &               +wliptran*gliptranc(j,i)
 279           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 280      &                  wbond*gradbx(j,i)+
 281      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 282      &                  wsccor*fact(2)*gsccorx(j,i)
 283      &                 +wliptran*gliptranx(j,i)
 284         else
 285           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 286      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 287      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 288      &                wbond*gradb(j,i)+
 289      &                wstrain*ghpbc(j,i)+
 290      &                wcorr*fact(3)*gradcorr(j,i)+
 291      &                wel_loc*fact(2)*gel_loc(j,i)+
 292      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 293      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 294      &                wcorr5*fact(4)*gradcorr5(j,i)+
 295      &                wcorr6*fact(5)*gradcorr6(j,i)+
 296      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 297      &                wsccor*fact(2)*gsccorc(j,i)
 298      &               +wliptran*gliptranc(j,i)
 299      &                 +welec*gshieldc(j,i)
 300      &                 +welec*gshieldc_loc(j,i)
 301      &                 +wcorr*gshieldc_ec(j,i)
 302      &                 +wcorr*gshieldc_loc_ec(j,i)
 303      &                 +wturn3*gshieldc_t3(j,i)
 304      &                 +wturn3*gshieldc_loc_t3(j,i)
 305      &                 +wturn4*gshieldc_t4(j,i)
 306      &                 +wturn4*gshieldc_loc_t4(j,i)
 307      &                 +wel_loc*gshieldc_ll(j,i)
 308      &                 +wel_loc*gshieldc_loc_ll(j,i)
 309
 310           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 311      &                 +fact(1)*wscp*gradx_scp(j,i)+
 312      &                  wbond*gradbx(j,i)+
 313      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 314      &                  wsccor*fact(2)*gsccorx(j,i)
 315      &                 +wliptran*gliptranx(j,i)
 316      &                 +welec*gshieldx(j,i)
 317      &                 +wcorr*gshieldx_ec(j,i)
 318      &                 +wturn3*gshieldx_t3(j,i)
 319      &                 +wturn4*gshieldx_t4(j,i)
 320      &                 +wel_loc*gshieldx_ll(j,i)
 321
 322
 323         endif
 324         enddo
 325 #else
 326       do i=1,nct
 327         do j=1,3
 328                 if (shield_mode.eq.0) then
 329           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 330      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 331      &                wbond*gradb(j,i)+
 332      &                wcorr*fact(3)*gradcorr(j,i)+
 333      &                wel_loc*fact(2)*gel_loc(j,i)+
 334      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 335      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 336      &                wcorr5*fact(4)*gradcorr5(j,i)+
 337      &                wcorr6*fact(5)*gradcorr6(j,i)+
 338      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 339      &                wsccor*fact(2)*gsccorc(j,i)
 340      &               +wliptran*gliptranc(j,i)
 341           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 342      &                  wbond*gradbx(j,i)+
 343      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 344      &                  wsccor*fact(1)*gsccorx(j,i)
 345      &                 +wliptran*gliptranx(j,i)
 346               else
 347           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 348      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 349      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 350      &                wbond*gradb(j,i)+
 351      &                wcorr*fact(3)*gradcorr(j,i)+
 352      &                wel_loc*fact(2)*gel_loc(j,i)+
 353      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 354      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 355      &                wcorr5*fact(4)*gradcorr5(j,i)+
 356      &                wcorr6*fact(5)*gradcorr6(j,i)+
 357      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 358      &                wsccor*fact(2)*gsccorc(j,i)
 359      &               +wliptran*gliptranc(j,i)
 360      &                 +welec*gshieldc(j,i)
 361      &                 +welec*gshieldc_loc(j,i)
 362      &                 +wcorr*gshieldc_ec(j,i)
 363      &                 +wcorr*gshieldc_loc_ec(j,i)
 364      &                 +wturn3*gshieldc_t3(j,i)
 365      &                 +wturn3*gshieldc_loc_t3(j,i)
 366      &                 +wturn4*gshieldc_t4(j,i)
 367      &                 +wturn4*gshieldc_loc_t4(j,i)
 368      &                 +wel_loc*gshieldc_ll(j,i)
 369      &                 +wel_loc*gshieldc_loc_ll(j,i)
 370
 371           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 372      &                  fact(1)*wscp*gradx_scp(j,i)+
 373      &                  wbond*gradbx(j,i)+
 374      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 375      &                  wsccor*fact(1)*gsccorx(j,i)
 376      &                 +wliptran*gliptranx(j,i)
 377      &                 +welec*gshieldx(j,i)
 378      &                 +wcorr*gshieldx_ec(j,i)
 379      &                 +wturn3*gshieldx_t3(j,i)
 380      &                 +wturn4*gshieldx_t4(j,i)
 381      &                 +wel_loc*gshieldx_ll(j,i)
 382
 383          endif
 384         enddo
 385 #endif
 386       enddo
 387
 388
 389       do i=1,nres-3
 390         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 391      &   +wcorr5*fact(4)*g_corr5_loc(i)
 392      &   +wcorr6*fact(5)*g_corr6_loc(i)
 393      &   +wturn4*fact(3)*gel_loc_turn4(i)
 394      &   +wturn3*fact(2)*gel_loc_turn3(i)
 395      &   +wturn6*fact(5)*gel_loc_turn6(i)
 396      &   +wel_loc*fact(2)*gel_loc_loc(i)
 397 c     &   +wsccor*fact(1)*gsccor_loc(i)
 398 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 399       enddo
 400       endif
 401       if (dyn_ss) call dyn_set_nss
 402       return
 403       end
 404 C------------------------------------------------------------------------
 405       subroutine enerprint(energia,fact)
 406       implicit real*8 (a-h,o-z)
 407       include 'DIMENSIONS'
 408       include 'COMMON.IOUNITS'
 409       include 'COMMON.FFIELD'
 410       include 'COMMON.SBRIDGE'
 411       double precision energia(0:max_ene),fact(6)
 412       etot=energia(0)
 413       evdw=energia(1)+fact(6)*energia(21)
 414 #ifdef SCP14
 415       evdw2=energia(2)+energia(17)
 416 #else
 417       evdw2=energia(2)
 418 #endif
 419       ees=energia(3)
 420 #ifdef SPLITELE
 421       evdw1=energia(16)
 422 #endif
 423       ecorr=energia(4)
 424       ecorr5=energia(5)
 425       ecorr6=energia(6)
 426       eel_loc=energia(7)
 427       eello_turn3=energia(8)
 428       eello_turn4=energia(9)
 429       eello_turn6=energia(10)
 430       ebe=energia(11)
 431       escloc=energia(12)
 432       etors=energia(13)
 433       etors_d=energia(14)
 434       ehpb=energia(15)
 435       esccor=energia(19)
 436       edihcnstr=energia(20)
 437       estr=energia(18)
 438       ethetacnstr=energia(24)
 439       eliptran=energia(22)
 440 #ifdef SPLITELE
 441       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 442      &  wvdwpp,
 443      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 444      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 445      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 446      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 447      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 448      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 449      & eliptran,wliptran,etot
 450    10 format (/'Virtual-chain energies:'//
 451      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 452      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 453      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 454      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 455      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 456      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 457      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 458      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 459      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 460      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 461      & ' (SS bridges & dist. cnstr.)'/
 462      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 463      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 464      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 465      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 466      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 467      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 468      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 469      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 470      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 471      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 472      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 473      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 474      & 'ETOT=  ',1pE16.6,' (total)')
 475 #else
 476       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 477      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 478      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 479      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 480      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 481      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 482      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 483    10 format (/'Virtual-chain energies:'//
 484      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 485      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 486      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 487      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 488      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 489      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 490      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 491      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 492      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 493      & ' (SS bridges & dist. cnstr.)'/
 494      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 495      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 496      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 497      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 498      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 499      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 500      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 501      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 502      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 503      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 504      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 505      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 506      & 'ETOT=  ',1pE16.6,' (total)')
 507 #endif
 508       return
 509       end
 510 C-----------------------------------------------------------------------
 511       subroutine elj(evdw,evdw_t)
 512 C
 513 C This subroutine calculates the interaction energy of nonbonded side chains
 514 C assuming the LJ potential of interaction.
 515 C
 516       implicit real*8 (a-h,o-z)
 517       include 'DIMENSIONS'
 518       include "DIMENSIONS.COMPAR"
 519       parameter (accur=1.0d-10)
 520       include 'COMMON.GEO'
 521       include 'COMMON.VAR'
 522       include 'COMMON.LOCAL'
 523       include 'COMMON.CHAIN'
 524       include 'COMMON.DERIV'
 525       include 'COMMON.INTERACT'
 526       include 'COMMON.TORSION'
 527       include 'COMMON.SBRIDGE'
 528       include 'COMMON.NAMES'
 529       include 'COMMON.IOUNITS'
 530       include 'COMMON.CONTACTS'
 531       dimension gg(3)
 532       integer icant
 533       external icant
 534 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 535 c ROZNICA z cluster
 536 c      do i=1,210
 537 c        do j=1,2
 538 c          eneps_temp(j,i)=0.0d0
 539 c        enddo
 540 c      enddo
 541 cROZNICA
 542
 543       evdw=0.0D0
 544       evdw_t=0.0d0
 545       do i=iatsc_s,iatsc_e
 546         itypi=iabs(itype(i))
 547         if (itypi.eq.ntyp1) cycle
 548         itypi1=iabs(itype(i+1))
 549         xi=c(1,nres+i)
 550         yi=c(2,nres+i)
 551         zi=c(3,nres+i)
 552 C Change 12/1/95
 553         num_conti=0
 554 C
 555 C Calculate SC interaction energy.
 556 C
 557         do iint=1,nint_gr(i)
 558 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 559 cd   &                  'iend=',iend(i,iint)
 560           do j=istart(i,iint),iend(i,iint)
 561             itypj=iabs(itype(j))
 562             if (itypj.eq.ntyp1) cycle
 563             xj=c(1,nres+j)-xi
 564             yj=c(2,nres+j)-yi
 565             zj=c(3,nres+j)-zi
 566 C Change 12/1/95 to calculate four-body interactions
 567             rij=xj*xj+yj*yj+zj*zj
 568             rrij=1.0D0/rij
 569 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 570             eps0ij=eps(itypi,itypj)
 571             fac=rrij**expon2
 572             e1=fac*fac*aa
 573             e2=fac*bb
 574             evdwij=e1+e2
 575             ij=icant(itypi,itypj)
 576 c ROZNICA z cluster
 577 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 578 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 579 c
 580
 581 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 582 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 583 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 584 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 585 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 586 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 587             if (bb.gt.0.0d0) then
 588               evdw=evdw+evdwij
 589             else
 590               evdw_t=evdw_t+evdwij
 591             endif
 592             if (calc_grad) then
 593 C
 594 C Calculate the components of the gradient in DC and X
 595 C
 596             fac=-rrij*(e1+evdwij)
 597             gg(1)=xj*fac
 598             gg(2)=yj*fac
 599             gg(3)=zj*fac
 600             do k=1,3
 601               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 602               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 603             enddo
 604             do k=i,j-1
 605               do l=1,3
 606                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 607               enddo
 608             enddo
 609             endif
 610 C
 611 C 12/1/95, revised on 5/20/97
 612 C
 613 C Calculate the contact function. The ith column of the array JCONT will
 614 C contain the numbers of atoms that make contacts with the atom I (of numbers
 615 C greater than I). The arrays FACONT and GACONT will contain the values of
 616 C the contact function and its derivative.
 617 C
 618 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 619 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 620 C Uncomment next line, if the correlation interactions are contact function only
 621             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 622               rij=dsqrt(rij)
 623               sigij=sigma(itypi,itypj)
 624               r0ij=rs0(itypi,itypj)
 625 C
 626 C Check whether the SC's are not too far to make a contact.
 627 C
 628               rcut=1.5d0*r0ij
 629               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 630 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 631 C
 632               if (fcont.gt.0.0D0) then
 633 C If the SC-SC distance if close to sigma, apply spline.
 634 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 635 cAdam &             fcont1,fprimcont1)
 636 cAdam           fcont1=1.0d0-fcont1
 637 cAdam           if (fcont1.gt.0.0d0) then
 638 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 639 cAdam             fcont=fcont*fcont1
 640 cAdam           endif
 641 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 642 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 643 cga             do k=1,3
 644 cga               gg(k)=gg(k)*eps0ij
 645 cga             enddo
 646 cga             eps0ij=-evdwij*eps0ij
 647 C Uncomment for AL's type of SC correlation interactions.
 648 cadam           eps0ij=-evdwij
 649                 num_conti=num_conti+1
 650                 jcont(num_conti,i)=j
 651                 facont(num_conti,i)=fcont*eps0ij
 652                 fprimcont=eps0ij*fprimcont/rij
 653                 fcont=expon*fcont
 654 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 655 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 656 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 657 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 658                 gacont(1,num_conti,i)=-fprimcont*xj
 659                 gacont(2,num_conti,i)=-fprimcont*yj
 660                 gacont(3,num_conti,i)=-fprimcont*zj
 661 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 662 cd              write (iout,'(2i3,3f10.5)')
 663 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 664               endif
 665             endif
 666           enddo      ! j
 667         enddo        ! iint
 668 C Change 12/1/95
 669         num_cont(i)=num_conti
 670       enddo          ! i
 671       if (calc_grad) then
 672       do i=1,nct
 673         do j=1,3
 674           gvdwc(j,i)=expon*gvdwc(j,i)
 675           gvdwx(j,i)=expon*gvdwx(j,i)
 676         enddo
 677       enddo
 678       endif
 679 C******************************************************************************
 680 C
 681 C                              N O T E !!!
 682 C
 683 C To save time, the factor of EXPON has been extracted from ALL components
 684 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 685 C use!
 686 C
 687 C******************************************************************************
 688       return
 689       end
 690 C-----------------------------------------------------------------------------
 691       subroutine eljk(evdw,evdw_t)
 692 C
 693 C This subroutine calculates the interaction energy of nonbonded side chains
 694 C assuming the LJK potential of interaction.
 695 C
 696       implicit real*8 (a-h,o-z)
 697       include 'DIMENSIONS'
 698       include "DIMENSIONS.COMPAR"
 699       include 'COMMON.GEO'
 700       include 'COMMON.VAR'
 701       include 'COMMON.LOCAL'
 702       include 'COMMON.CHAIN'
 703       include 'COMMON.DERIV'
 704       include 'COMMON.INTERACT'
 705       include 'COMMON.IOUNITS'
 706       include 'COMMON.NAMES'
 707       dimension gg(3)
 708       logical scheck
 709       integer icant
 710       external icant
 711 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 712 c      do i=1,210
 713 c        do j=1,2
 714 c          eneps_temp(j,i)=0.0d0
 715 c        enddo
 716 c      enddo
 717       evdw=0.0D0
 718       evdw_t=0.0d0
 719       do i=iatsc_s,iatsc_e
 720         itypi=iabs(itype(i))
 721         if (itypi.eq.ntyp1) cycle
 722         itypi1=iabs(itype(i+1))
 723         xi=c(1,nres+i)
 724         yi=c(2,nres+i)
 725         zi=c(3,nres+i)
 726 C
 727 C Calculate SC interaction energy.
 728 C
 729         do iint=1,nint_gr(i)
 730           do j=istart(i,iint),iend(i,iint)
 731             itypj=iabs(itype(j))
 732             if (itypj.eq.ntyp1) cycle
 733             xj=c(1,nres+j)-xi
 734             yj=c(2,nres+j)-yi
 735             zj=c(3,nres+j)-zi
 736             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 737             fac_augm=rrij**expon
 738             e_augm=augm(itypi,itypj)*fac_augm
 739             r_inv_ij=dsqrt(rrij)
 740             rij=1.0D0/r_inv_ij
 741             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 742             fac=r_shift_inv**expon
 743             e1=fac*fac*aa
 744             e2=fac*bb
 745             evdwij=e_augm+e1+e2
 746             ij=icant(itypi,itypj)
 747 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 748 c     &        /dabs(eps(itypi,itypj))
 749 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 750 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 751 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 752 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 753 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 754 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 755 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 756 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 757             if (bb.gt.0.0d0) then
 758               evdw=evdw+evdwij
 759             else
 760               evdw_t=evdw_t+evdwij
 761             endif
 762             if (calc_grad) then
 763 C
 764 C Calculate the components of the gradient in DC and X
 765 C
 766             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 767             gg(1)=xj*fac
 768             gg(2)=yj*fac
 769             gg(3)=zj*fac
 770             do k=1,3
 771               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 772               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 773             enddo
 774             do k=i,j-1
 775               do l=1,3
 776                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 777               enddo
 778             enddo
 779             endif
 780           enddo      ! j
 781         enddo        ! iint
 782       enddo          ! i
 783       if (calc_grad) then
 784       do i=1,nct
 785         do j=1,3
 786           gvdwc(j,i)=expon*gvdwc(j,i)
 787           gvdwx(j,i)=expon*gvdwx(j,i)
 788         enddo
 789       enddo
 790       endif
 791       return
 792       end
 793 C-----------------------------------------------------------------------------
 794       subroutine ebp(evdw,evdw_t)
 795 C
 796 C This subroutine calculates the interaction energy of nonbonded side chains
 797 C assuming the Berne-Pechukas potential of interaction.
 798 C
 799       implicit real*8 (a-h,o-z)
 800       include 'DIMENSIONS'
 801       include "DIMENSIONS.COMPAR"
 802       include 'COMMON.GEO'
 803       include 'COMMON.VAR'
 804       include 'COMMON.LOCAL'
 805       include 'COMMON.CHAIN'
 806       include 'COMMON.DERIV'
 807       include 'COMMON.NAMES'
 808       include 'COMMON.INTERACT'
 809       include 'COMMON.IOUNITS'
 810       include 'COMMON.CALC'
 811       common /srutu/ icall
 812 c     double precision rrsave(maxdim)
 813       logical lprn
 814       integer icant
 815       external icant
 816 c      do i=1,210
 817 c        do j=1,2
 818 c          eneps_temp(j,i)=0.0d0
 819 c        enddo
 820 c      enddo
 821       evdw=0.0D0
 822       evdw_t=0.0d0
 823 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 824 c     if (icall.eq.0) then
 825 c       lprn=.true.
 826 c     else
 827         lprn=.false.
 828 c     endif
 829       ind=0
 830       do i=iatsc_s,iatsc_e
 831         itypi=iabs(itype(i))
 832         if (itypi.eq.ntyp1) cycle
 833         itypi1=iabs(itype(i+1))
 834         xi=c(1,nres+i)
 835         yi=c(2,nres+i)
 836         zi=c(3,nres+i)
 837         dxi=dc_norm(1,nres+i)
 838         dyi=dc_norm(2,nres+i)
 839         dzi=dc_norm(3,nres+i)
 840         dsci_inv=vbld_inv(i+nres)
 841 C
 842 C Calculate SC interaction energy.
 843 C
 844         do iint=1,nint_gr(i)
 845           do j=istart(i,iint),iend(i,iint)
 846             ind=ind+1
 847             itypj=iabs(itype(j))
 848             if (itypj.eq.ntyp1) cycle
 849             dscj_inv=vbld_inv(j+nres)
 850             chi1=chi(itypi,itypj)
 851             chi2=chi(itypj,itypi)
 852             chi12=chi1*chi2
 853             chip1=chip(itypi)
 854             chip2=chip(itypj)
 855             chip12=chip1*chip2
 856             alf1=alp(itypi)
 857             alf2=alp(itypj)
 858             alf12=0.5D0*(alf1+alf2)
 859 C For diagnostics only!!!
 860 c           chi1=0.0D0
 861 c           chi2=0.0D0
 862 c           chi12=0.0D0
 863 c           chip1=0.0D0
 864 c           chip2=0.0D0
 865 c           chip12=0.0D0
 866 c           alf1=0.0D0
 867 c           alf2=0.0D0
 868 c           alf12=0.0D0
 869             xj=c(1,nres+j)-xi
 870             yj=c(2,nres+j)-yi
 871             zj=c(3,nres+j)-zi
 872             dxj=dc_norm(1,nres+j)
 873             dyj=dc_norm(2,nres+j)
 874             dzj=dc_norm(3,nres+j)
 875             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 876 cd          if (icall.eq.0) then
 877 cd            rrsave(ind)=rrij
 878 cd          else
 879 cd            rrij=rrsave(ind)
 880 cd          endif
 881             rij=dsqrt(rrij)
 882 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 883             call sc_angular
 884 C Calculate whole angle-dependent part of epsilon and contributions
 885 C to its derivatives
 886             fac=(rrij*sigsq)**expon2
 887             e1=fac*fac*aa
 888             e2=fac*bb
 889             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 890             eps2der=evdwij*eps3rt
 891             eps3der=evdwij*eps2rt
 892             evdwij=evdwij*eps2rt*eps3rt
 893             ij=icant(itypi,itypj)
 894             aux=eps1*eps2rt**2*eps3rt**2
 895 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 896 c     &        /dabs(eps(itypi,itypj))
 897 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 898             if (bb.gt.0.0d0) then
 899               evdw=evdw+evdwij
 900             else
 901               evdw_t=evdw_t+evdwij
 902             endif
 903             if (calc_grad) then
 904             if (lprn) then
 905             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 906             epsi=bb**2/aa
 907             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 908      &        restyp(itypi),i,restyp(itypj),j,
 909      &        epsi,sigm,chi1,chi2,chip1,chip2,
 910      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 911      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 912      &        evdwij
 913             endif
 914 C Calculate gradient components.
 915             e1=e1*eps1*eps2rt**2*eps3rt**2
 916             fac=-expon*(e1+evdwij)
 917             sigder=fac/sigsq
 918             fac=rrij*fac
 919 C Calculate radial part of the gradient
 920             gg(1)=xj*fac
 921             gg(2)=yj*fac
 922             gg(3)=zj*fac
 923 C Calculate the angular part of the gradient and sum add the contributions
 924 C to the appropriate components of the Cartesian gradient.
 925             call sc_grad
 926             endif
 927           enddo      ! j
 928         enddo        ! iint
 929       enddo          ! i
 930 c     stop
 931       return
 932       end
 933 C-----------------------------------------------------------------------------
 934       subroutine egb(evdw,evdw_t)
 935 C
 936 C This subroutine calculates the interaction energy of nonbonded side chains
 937 C assuming the Gay-Berne potential of interaction.
 938 C
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include "DIMENSIONS.COMPAR"
 942       include 'COMMON.GEO'
 943       include 'COMMON.VAR'
 944       include 'COMMON.LOCAL'
 945       include 'COMMON.CHAIN'
 946       include 'COMMON.DERIV'
 947       include 'COMMON.NAMES'
 948       include 'COMMON.INTERACT'
 949       include 'COMMON.IOUNITS'
 950       include 'COMMON.CALC'
 951       include 'COMMON.SBRIDGE'
 952       logical lprn
 953       common /srutu/icall
 954       integer icant,xshift,yshift,zshift
 955       external icant
 956 c      do i=1,210
 957 c        do j=1,2
 958 c          eneps_temp(j,i)=0.0d0
 959 c        enddo
 960 c      enddo
 961 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 962       evdw=0.0D0
 963       evdw_t=0.0d0
 964       lprn=.false.
 965 c      if (icall.gt.0) lprn=.true.
 966       ind=0
 967       do i=iatsc_s,iatsc_e
 968         itypi=iabs(itype(i))
 969         if (itypi.eq.ntyp1) cycle
 970         itypi1=iabs(itype(i+1))
 971         xi=c(1,nres+i)
 972         yi=c(2,nres+i)
 973         zi=c(3,nres+i)
 974 C returning the ith atom to box
 975           xi=mod(xi,boxxsize)
 976           if (xi.lt.0) xi=xi+boxxsize
 977           yi=mod(yi,boxysize)
 978           if (yi.lt.0) yi=yi+boxysize
 979           zi=mod(zi,boxzsize)
 980           if (zi.lt.0) zi=zi+boxzsize
 981        if ((zi.gt.bordlipbot)
 982      &.and.(zi.lt.bordliptop)) then
 983 C the energy transfer exist
 984         if (zi.lt.buflipbot) then
 985 C what fraction I am in
 986          fracinbuf=1.0d0-
 987      &        ((zi-bordlipbot)/lipbufthick)
 988 C lipbufthick is thickenes of lipid buffore
 989          sslipi=sscalelip(fracinbuf)
 990          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 991         elseif (zi.gt.bufliptop) then
 992          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 993          sslipi=sscalelip(fracinbuf)
 994          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 995         else
 996          sslipi=1.0d0
 997          ssgradlipi=0.0
 998         endif
 999        else
1000          sslipi=0.0d0
1001          ssgradlipi=0.0
1002        endif
1003
1004         dxi=dc_norm(1,nres+i)
1005         dyi=dc_norm(2,nres+i)
1006         dzi=dc_norm(3,nres+i)
1007         dsci_inv=vbld_inv(i+nres)
1008 C
1009 C Calculate SC interaction energy.
1010 C
1011         do iint=1,nint_gr(i)
1012           do j=istart(i,iint),iend(i,iint)
1013             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1014               call dyn_ssbond_ene(i,j,evdwij)
1015               evdw=evdw+evdwij
1016 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1017 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1018 C triple bond artifac removal
1019              do k=j+1,iend(i,iint)
1020 C search over all next residues
1021               if (dyn_ss_mask(k)) then
1022 C check if they are cysteins
1023 C              write(iout,*) 'k=',k
1024               call triple_ssbond_ene(i,j,k,evdwij)
1025 C call the energy function that removes the artifical triple disulfide
1026 C bond the soubroutine is located in ssMD.F
1027               evdw=evdw+evdwij
1028 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1029 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1030               endif!dyn_ss_mask(k)
1031              enddo! k
1032             ELSE
1033             ind=ind+1
1034             itypj=iabs(itype(j))
1035             if (itypj.eq.ntyp1) cycle
1036             dscj_inv=vbld_inv(j+nres)
1037             sig0ij=sigma(itypi,itypj)
1038             chi1=chi(itypi,itypj)
1039             chi2=chi(itypj,itypi)
1040             chi12=chi1*chi2
1041             chip1=chip(itypi)
1042             chip2=chip(itypj)
1043             chip12=chip1*chip2
1044             alf1=alp(itypi)
1045             alf2=alp(itypj)
1046             alf12=0.5D0*(alf1+alf2)
1047 C For diagnostics only!!!
1048 c           chi1=0.0D0
1049 c           chi2=0.0D0
1050 c           chi12=0.0D0
1051 c           chip1=0.0D0
1052 c           chip2=0.0D0
1053 c           chip12=0.0D0
1054 c           alf1=0.0D0
1055 c           alf2=0.0D0
1056 c           alf12=0.0D0
1057             xj=c(1,nres+j)
1058             yj=c(2,nres+j)
1059             zj=c(3,nres+j)
1060 C returning jth atom to box
1061           xj=mod(xj,boxxsize)
1062           if (xj.lt.0) xj=xj+boxxsize
1063           yj=mod(yj,boxysize)
1064           if (yj.lt.0) yj=yj+boxysize
1065           zj=mod(zj,boxzsize)
1066           if (zj.lt.0) zj=zj+boxzsize
1067        if ((zj.gt.bordlipbot)
1068      &.and.(zj.lt.bordliptop)) then
1069 C the energy transfer exist
1070         if (zj.lt.buflipbot) then
1071 C what fraction I am in
1072          fracinbuf=1.0d0-
1073      &        ((zj-bordlipbot)/lipbufthick)
1074 C lipbufthick is thickenes of lipid buffore
1075          sslipj=sscalelip(fracinbuf)
1076          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1077         elseif (zj.gt.bufliptop) then
1078          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1079          sslipj=sscalelip(fracinbuf)
1080          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1081         else
1082          sslipj=1.0d0
1083          ssgradlipj=0.0
1084         endif
1085        else
1086          sslipj=0.0d0
1087          ssgradlipj=0.0
1088        endif
1089       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1090      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1091       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1092      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1093 C       if (aa.ne.aa_aq(itypi,itypj)) then
1094
1095 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1096 C     & bb_aq(itypi,itypj)-bb,
1097 C     & sslipi,sslipj
1098 C         endif
1099
1100 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1101 C checking the distance
1102       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1103       xj_safe=xj
1104       yj_safe=yj
1105       zj_safe=zj
1106       subchap=0
1107 C finding the closest
1108       do xshift=-1,1
1109       do yshift=-1,1
1110       do zshift=-1,1
1111           xj=xj_safe+xshift*boxxsize
1112           yj=yj_safe+yshift*boxysize
1113           zj=zj_safe+zshift*boxzsize
1114           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1115           if(dist_temp.lt.dist_init) then
1116             dist_init=dist_temp
1117             xj_temp=xj
1118             yj_temp=yj
1119             zj_temp=zj
1120             subchap=1
1121           endif
1122        enddo
1123        enddo
1124        enddo
1125        if (subchap.eq.1) then
1126           xj=xj_temp-xi
1127           yj=yj_temp-yi
1128           zj=zj_temp-zi
1129        else
1130           xj=xj_safe-xi
1131           yj=yj_safe-yi
1132           zj=zj_safe-zi
1133        endif
1134
1135             dxj=dc_norm(1,nres+j)
1136             dyj=dc_norm(2,nres+j)
1137             dzj=dc_norm(3,nres+j)
1138 c            write (iout,*) i,j,xj,yj,zj
1139             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1140             rij=dsqrt(rrij)
1141             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1142             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1143             if (sss.le.0.0) cycle
1144 C Calculate angle-dependent terms of energy and contributions to their
1145 C derivatives.
1146
1147             call sc_angular
1148             sigsq=1.0D0/sigsq
1149             sig=sig0ij*dsqrt(sigsq)
1150             rij_shift=1.0D0/rij-sig+sig0ij
1151 C I hate to put IF's in the loops, but here don't have another choice!!!!
1152             if (rij_shift.le.0.0D0) then
1153               evdw=1.0D20
1154               return
1155             endif
1156             sigder=-sig*sigsq
1157 c---------------------------------------------------------------
1158             rij_shift=1.0D0/rij_shift
1159             fac=rij_shift**expon
1160             e1=fac*fac*aa
1161             e2=fac*bb
1162             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1163             eps2der=evdwij*eps3rt
1164             eps3der=evdwij*eps2rt
1165             evdwij=evdwij*eps2rt*eps3rt
1166             if (bb.gt.0) then
1167               evdw=evdw+evdwij*sss
1168             else
1169               evdw_t=evdw_t+evdwij*sss
1170             endif
1171             ij=icant(itypi,itypj)
1172             aux=eps1*eps2rt**2*eps3rt**2
1173 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1174 c     &        /dabs(eps(itypi,itypj))
1175 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1176 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1177 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1178 c     &         aux*e2/eps(itypi,itypj)
1179 c            if (lprn) then
1180             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1181             epsi=bb**2/aa
1182 C#define DEBUG
1183 #ifdef DEBUG
1184             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1185      &        restyp(itypi),i,restyp(itypj),j,
1186      &        epsi,sigm,chi1,chi2,chip1,chip2,
1187      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1188      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1189      &        evdwij
1190              write (iout,*) "partial sum", evdw, evdw_t
1191 #endif
1192 C#undef DEBUG
1193 c            endif
1194             if (calc_grad) then
1195 C Calculate gradient components.
1196             e1=e1*eps1*eps2rt**2*eps3rt**2
1197             fac=-expon*(e1+evdwij)*rij_shift
1198             sigder=fac*sigder
1199             fac=rij*fac
1200             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1201 C Calculate the radial part of the gradient
1202             gg(1)=xj*fac
1203             gg(2)=yj*fac
1204             gg(3)=zj*fac
1205 C Calculate angular part of the gradient.
1206             call sc_grad
1207             endif
1208 C            write(iout,*)  "partial sum", evdw, evdw_t
1209             ENDIF    ! dyn_ss
1210           enddo      ! j
1211         enddo        ! iint
1212       enddo          ! i
1213       return
1214       end
1215 C-----------------------------------------------------------------------------
1216       subroutine egbv(evdw,evdw_t)
1217 C
1218 C This subroutine calculates the interaction energy of nonbonded side chains
1219 C assuming the Gay-Berne-Vorobjev potential of interaction.
1220 C
1221       implicit real*8 (a-h,o-z)
1222       include 'DIMENSIONS'
1223       include "DIMENSIONS.COMPAR"
1224       include 'COMMON.CONTROL'
1225       include 'COMMON.GEO'
1226       include 'COMMON.VAR'
1227       include 'COMMON.LOCAL'
1228       include 'COMMON.CHAIN'
1229       include 'COMMON.DERIV'
1230       include 'COMMON.NAMES'
1231       include 'COMMON.INTERACT'
1232       include 'COMMON.IOUNITS'
1233       include 'COMMON.CALC'
1234       include 'COMMON.SBRIDGE'
1235       common /srutu/ icall
1236       logical lprn
1237       integer icant
1238       external icant
1239 c      do i=1,210
1240 c        do j=1,2
1241 c          eneps_temp(j,i)=0.0d0
1242 c        enddo
1243 c      enddo
1244       evdw=0.0D0
1245       evdw_t=0.0d0
1246 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1247       evdw=0.0D0
1248       lprn=.false.
1249 c      if (icall.gt.0) lprn=.true.
1250       ind=0
1251       do i=iatsc_s,iatsc_e
1252         itypi=iabs(itype(i))
1253         if (itypi.eq.ntyp1) cycle
1254         itypi1=iabs(itype(i+1))
1255         xi=c(1,nres+i)
1256         yi=c(2,nres+i)
1257         zi=c(3,nres+i)
1258 C returning the ith atom to box
1259         xi=mod(xi,boxxsize)
1260         if (xi.lt.0) xi=xi+boxxsize
1261         yi=mod(yi,boxysize)
1262         if (yi.lt.0) yi=yi+boxysize
1263         zi=mod(zi,boxzsize)
1264         if (zi.lt.0) zi=zi+boxzsize
1265         if ((zi.gt.bordlipbot)
1266      &  .and.(zi.lt.bordliptop)) then
1267 C the energy transfer exist
1268           if (zi.lt.buflipbot) then
1269 C what fraction I am in
1270             fracinbuf=1.0d0-
1271      &        ((zi-bordlipbot)/lipbufthick)
1272 C lipbufthick is thickenes of lipid buffore
1273             sslipi=sscalelip(fracinbuf)
1274             ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1275           elseif (zi.gt.bufliptop) then
1276             fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1277             sslipi=sscalelip(fracinbuf)
1278             ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1279           else
1280             sslipi=1.0d0
1281             ssgradlipi=0.0
1282           endif
1283         else
1284           sslipi=0.0d0
1285           ssgradlipi=0.0
1286         endif
1287         dxi=dc_norm(1,nres+i)
1288         dyi=dc_norm(2,nres+i)
1289         dzi=dc_norm(3,nres+i)
1290         dsci_inv=vbld_inv(i+nres)
1291         dxi=dc_norm(1,nres+i)
1292         dyi=dc_norm(2,nres+i)
1293         dzi=dc_norm(3,nres+i)
1294         dsci_inv=vbld_inv(i+nres)
1295 C
1296 C Calculate SC interaction energy.
1297 C
1298         do iint=1,nint_gr(i)
1299           do j=istart(i,iint),iend(i,iint)
1300             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1301               call dyn_ssbond_ene(i,j,evdwij)
1302               evdw=evdw+evdwij
1303               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1304      &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1305 C triple bond artifac removal
1306              do k=j+1,iend(i,iint)
1307 C search over all next residues
1308               if (dyn_ss_mask(k)) then
1309 C check if they are cysteins
1310 C              write(iout,*) 'k=',k
1311               call triple_ssbond_ene(i,j,k,evdwij)
1312 C call the energy function that removes the artifical triple disulfide
1313 C bond the soubroutine is located in ssMD.F
1314               evdw=evdw+evdwij
1315              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1316      &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1317               endif!dyn_ss_mask(k)
1318              enddo! k
1319             ELSE
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323             dscj_inv=vbld_inv(j+nres)
1324             sig0ij=sigma(itypi,itypj)
1325             r0ij=r0(itypi,itypj)
1326             chi1=chi(itypi,itypj)
1327             chi2=chi(itypj,itypi)
1328             chi12=chi1*chi2
1329             chip1=chip(itypi)
1330             chip2=chip(itypj)
1331             chip12=chip1*chip2
1332             alf1=alp(itypi)
1333             alf2=alp(itypj)
1334             alf12=0.5D0*(alf1+alf2)
1335 C For diagnostics only!!!
1336 c           chi1=0.0D0
1337 c           chi2=0.0D0
1338 c           chi12=0.0D0
1339 c           chip1=0.0D0
1340 c           chip2=0.0D0
1341 c           chip12=0.0D0
1342 c           alf1=0.0D0
1343 c           alf2=0.0D0
1344 c           alf12=0.0D0
1345             xj=c(1,nres+j)
1346             yj=c(2,nres+j)
1347             zj=c(3,nres+j)
1348 C returning jth atom to box
1349             xj=mod(xj,boxxsize)
1350             if (xj.lt.0) xj=xj+boxxsize
1351             yj=mod(yj,boxysize)
1352             if (yj.lt.0) yj=yj+boxysize
1353             zj=mod(zj,boxzsize)
1354             if (zj.lt.0) zj=zj+boxzsize
1355             if ((zj.gt.bordlipbot)
1356      &        .and.(zj.lt.bordliptop)) then
1357 C the energy transfer exist
1358               if (zj.lt.buflipbot) then
1359 C what fraction I am in
1360                 fracinbuf=1.0d0-
1361      &          ((zj-bordlipbot)/lipbufthick)
1362 C lipbufthick is thickenes of lipid buffore
1363                 sslipj=sscalelip(fracinbuf)
1364                 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1365               elseif (zj.gt.bufliptop) then
1366                 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1367                 sslipj=sscalelip(fracinbuf)
1368                 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1369               else
1370                 sslipj=1.0d0
1371                 ssgradlipj=0.0
1372               endif
1373             else
1374               sslipj=0.0d0
1375               ssgradlipj=0.0
1376             endif
1377             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1378      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1379             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1380      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1381 C       if (aa.ne.aa_aq(itypi,itypj)) then
1382
1383 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1384 C     & bb_aq(itypi,itypj)-bb,
1385 C     & sslipi,sslipj
1386 C         endif
1387
1388 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1389 C checking the distance
1390             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1391             xj_safe=xj
1392             yj_safe=yj
1393             zj_safe=zj
1394             subchap=0
1395 C finding the closest
1396             do xshift=-1,1
1397               do yshift=-1,1
1398                 do zshift=-1,1
1399                   xj=xj_safe+xshift*boxxsize
1400                   yj=yj_safe+yshift*boxysize
1401                   zj=zj_safe+zshift*boxzsize
1402                   dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1403                   if (dist_temp.lt.dist_init) then
1404                     dist_init=dist_temp
1405                     xj_temp=xj
1406                     yj_temp=yj
1407                     zj_temp=zj
1408                     subchap=1
1409                   endif
1410                 enddo
1411               enddo
1412             enddo
1413             if (subchap.eq.1) then
1414               xj=xj_temp-xi
1415               yj=yj_temp-yi
1416               zj=zj_temp-zi
1417             else
1418               xj=xj_safe-xi
1419               yj=yj_safe-yi
1420               zj=zj_safe-zi
1421             endif
1422
1423             dxj=dc_norm(1,nres+j)
1424             dyj=dc_norm(2,nres+j)
1425             dzj=dc_norm(3,nres+j)
1426 c            write (iout,*) i,j,xj,yj,zj
1427             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1428             rij=dsqrt(rrij)
1429             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1430             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1431             if (sss.le.0.0) cycle
1432 C Calculate angle-dependent terms of energy and contributions to their
1433 C derivatives.
1434
1435             call sc_angular
1436             sigsq=1.0D0/sigsq
1437             sig=sig0ij*dsqrt(sigsq)
1438             rij_shift=1.0D0/rij-sig+r0ij
1439 C I hate to put IF's in the loops, but here don't have another choice!!!!
1440             if (rij_shift.le.0.0D0) then
1441               evdw=1.0D20
1442               return
1443             endif
1444             sigder=-sig*sigsq
1445 c---------------------------------------------------------------
1446             rij_shift=1.0D0/rij_shift
1447             fac=rij_shift**expon
1448             e1=fac*fac*aa
1449             e2=fac*bb
1450             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1451             eps2der=evdwij*eps3rt
1452             eps3der=evdwij*eps2rt
1453             fac_augm=rrij**expon
1454             e_augm=augm(itypi,itypj)*fac_augm
1455             evdwij=evdwij*eps2rt*eps3rt
1456             if (bb.gt.0) then
1457               evdw=evdw+evdwij*sss+e_augm
1458             else
1459               evdw_t=evdw_t+evdwij*sss+e_augm
1460             endif
1461 c            evdw=evdw+evdwij+e_augm
1462             ij=icant(itypi,itypj)
1463             aux=eps1*eps2rt**2*eps3rt**2
1464 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1465 c     &        /dabs(eps(itypi,itypj))
1466 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1467 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1468 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1469 c     &         aux*e2/eps(itypi,itypj)
1470 c            if (lprn) then
1471 c#define DEBUG
1472 #ifdef DEBUG
1473             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1474             epsi=bb**2/aa
1475             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1476      &        restyp(itypi),i,restyp(itypj),j,
1477      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1478      &        chi1,chi2,chip1,chip2,
1479      &        eps1,eps2rt**2,eps3rt**2,
1480      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1481      &        evdwij+e_augm
1482              write (iout,*) "partial sum", evdw, evdw_t
1483 #endif
1484 c#undef DEBUG
1485 c            endif
1486             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1487      &                        'evdw',i,j,evdwij
1488             if (calc_grad) then
1489 C Calculate gradient components.
1490             e1=e1*eps1*eps2rt**2*eps3rt**2
1491             fac=-expon*(e1+evdwij)*rij_shift
1492             sigder=fac*sigder
1493             fac=rij*fac
1494             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1495 C Calculate the radial part of the gradient
1496             gg(1)=xj*fac
1497             gg(2)=yj*fac
1498             gg(3)=zj*fac
1499 C Calculate angular part of the gradient.
1500             call sc_grad
1501             endif
1502             ENDIF
1503           enddo      ! j
1504         enddo        ! iint
1505       enddo          ! i
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine sc_angular
1510 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1511 C om12. Called by ebp, egb, and egbv.
1512       implicit none
1513       include 'COMMON.CALC'
1514       erij(1)=xj*rij
1515       erij(2)=yj*rij
1516       erij(3)=zj*rij
1517       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1518       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1519       om12=dxi*dxj+dyi*dyj+dzi*dzj
1520       chiom12=chi12*om12
1521 C Calculate eps1(om12) and its derivative in om12
1522       faceps1=1.0D0-om12*chiom12
1523       faceps1_inv=1.0D0/faceps1
1524       eps1=dsqrt(faceps1_inv)
1525 C Following variable is eps1*deps1/dom12
1526       eps1_om12=faceps1_inv*chiom12
1527 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1528 C and om12.
1529       om1om2=om1*om2
1530       chiom1=chi1*om1
1531       chiom2=chi2*om2
1532       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1533       sigsq=1.0D0-facsig*faceps1_inv
1534       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1535       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1536       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1537 C Calculate eps2 and its derivatives in om1, om2, and om12.
1538       chipom1=chip1*om1
1539       chipom2=chip2*om2
1540       chipom12=chip12*om12
1541       facp=1.0D0-om12*chipom12
1542       facp_inv=1.0D0/facp
1543       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1544 C Following variable is the square root of eps2
1545       eps2rt=1.0D0-facp1*facp_inv
1546 C Following three variables are the derivatives of the square root of eps
1547 C in om1, om2, and om12.
1548       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1549       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1550       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1551 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1552       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1553 C Calculate whole angle-dependent part of epsilon and contributions
1554 C to its derivatives
1555       return
1556       end
1557 C----------------------------------------------------------------------------
1558       subroutine sc_grad
1559       implicit real*8 (a-h,o-z)
1560       include 'DIMENSIONS'
1561       include 'COMMON.CHAIN'
1562       include 'COMMON.DERIV'
1563       include 'COMMON.CALC'
1564       double precision dcosom1(3),dcosom2(3)
1565       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1566       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1567       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1568      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1569       do k=1,3
1570         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1571         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1572       enddo
1573       do k=1,3
1574         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1575       enddo
1576       do k=1,3
1577         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1578      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1579      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1580         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1581      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1582      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1583       enddo
1584 C
1585 C Calculate the components of the gradient in DC and X
1586 C
1587       do k=i,j-1
1588         do l=1,3
1589           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1590         enddo
1591       enddo
1592       return
1593       end
1594 c------------------------------------------------------------------------------
1595       subroutine vec_and_deriv
1596       implicit real*8 (a-h,o-z)
1597       include 'DIMENSIONS'
1598       include 'COMMON.IOUNITS'
1599       include 'COMMON.GEO'
1600       include 'COMMON.VAR'
1601       include 'COMMON.LOCAL'
1602       include 'COMMON.CHAIN'
1603       include 'COMMON.VECTORS'
1604       include 'COMMON.DERIV'
1605       include 'COMMON.INTERACT'
1606       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1607 C Compute the local reference systems. For reference system (i), the
1608 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1609 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1610       do i=1,nres-1
1611 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1612           if (i.eq.nres-1) then
1613 C Case of the last full residue
1614 C Compute the Z-axis
1615             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1616             costh=dcos(pi-theta(nres))
1617             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1618 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1619 c     &         " uz",uz(:,i)
1620             do k=1,3
1621               uz(k,i)=fac*uz(k,i)
1622             enddo
1623             if (calc_grad) then
1624 C Compute the derivatives of uz
1625             uzder(1,1,1)= 0.0d0
1626             uzder(2,1,1)=-dc_norm(3,i-1)
1627             uzder(3,1,1)= dc_norm(2,i-1)
1628             uzder(1,2,1)= dc_norm(3,i-1)
1629             uzder(2,2,1)= 0.0d0
1630             uzder(3,2,1)=-dc_norm(1,i-1)
1631             uzder(1,3,1)=-dc_norm(2,i-1)
1632             uzder(2,3,1)= dc_norm(1,i-1)
1633             uzder(3,3,1)= 0.0d0
1634             uzder(1,1,2)= 0.0d0
1635             uzder(2,1,2)= dc_norm(3,i)
1636             uzder(3,1,2)=-dc_norm(2,i)
1637             uzder(1,2,2)=-dc_norm(3,i)
1638             uzder(2,2,2)= 0.0d0
1639             uzder(3,2,2)= dc_norm(1,i)
1640             uzder(1,3,2)= dc_norm(2,i)
1641             uzder(2,3,2)=-dc_norm(1,i)
1642             uzder(3,3,2)= 0.0d0
1643             endif ! calc_grad
1644 C Compute the Y-axis
1645             facy=fac
1646             do k=1,3
1647               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1648             enddo
1649             if (calc_grad) then
1650 C Compute the derivatives of uy
1651             do j=1,3
1652               do k=1,3
1653                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1654      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1655                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1656               enddo
1657               uyder(j,j,1)=uyder(j,j,1)-costh
1658               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1659             enddo
1660             do j=1,2
1661               do k=1,3
1662                 do l=1,3
1663                   uygrad(l,k,j,i)=uyder(l,k,j)
1664                   uzgrad(l,k,j,i)=uzder(l,k,j)
1665                 enddo
1666               enddo
1667             enddo
1668             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1669             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1670             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1671             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1672             endif
1673           else
1674 C Other residues
1675 C Compute the Z-axis
1676             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1677             costh=dcos(pi-theta(i+2))
1678             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1679             do k=1,3
1680               uz(k,i)=fac*uz(k,i)
1681             enddo
1682             if (calc_grad) then
1683 C Compute the derivatives of uz
1684             uzder(1,1,1)= 0.0d0
1685             uzder(2,1,1)=-dc_norm(3,i+1)
1686             uzder(3,1,1)= dc_norm(2,i+1)
1687             uzder(1,2,1)= dc_norm(3,i+1)
1688             uzder(2,2,1)= 0.0d0
1689             uzder(3,2,1)=-dc_norm(1,i+1)
1690             uzder(1,3,1)=-dc_norm(2,i+1)
1691             uzder(2,3,1)= dc_norm(1,i+1)
1692             uzder(3,3,1)= 0.0d0
1693             uzder(1,1,2)= 0.0d0
1694             uzder(2,1,2)= dc_norm(3,i)
1695             uzder(3,1,2)=-dc_norm(2,i)
1696             uzder(1,2,2)=-dc_norm(3,i)
1697             uzder(2,2,2)= 0.0d0
1698             uzder(3,2,2)= dc_norm(1,i)
1699             uzder(1,3,2)= dc_norm(2,i)
1700             uzder(2,3,2)=-dc_norm(1,i)
1701             uzder(3,3,2)= 0.0d0
1702             endif
1703 C Compute the Y-axis
1704             facy=fac
1705             do k=1,3
1706               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1707             enddo
1708             if (calc_grad) then
1709 C Compute the derivatives of uy
1710             do j=1,3
1711               do k=1,3
1712                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1713      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1714                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1715               enddo
1716               uyder(j,j,1)=uyder(j,j,1)-costh
1717               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1718             enddo
1719             do j=1,2
1720               do k=1,3
1721                 do l=1,3
1722                   uygrad(l,k,j,i)=uyder(l,k,j)
1723                   uzgrad(l,k,j,i)=uzder(l,k,j)
1724                 enddo
1725               enddo
1726             enddo
1727             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1728             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1729             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1730             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1731           endif
1732           endif
1733       enddo
1734       if (calc_grad) then
1735       do i=1,nres-1
1736         vbld_inv_temp(1)=vbld_inv(i+1)
1737         if (i.lt.nres-1) then
1738           vbld_inv_temp(2)=vbld_inv(i+2)
1739         else
1740           vbld_inv_temp(2)=vbld_inv(i)
1741         endif
1742         do j=1,2
1743           do k=1,3
1744             do l=1,3
1745               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1746               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1747             enddo
1748           enddo
1749         enddo
1750       enddo
1751       endif
1752       return
1753       end
1754 C--------------------------------------------------------------------------
1755       subroutine set_matrices
1756       implicit real*8 (a-h,o-z)
1757       include 'DIMENSIONS'
1758 #ifdef MPI
1759       include "mpif.h"
1760       integer IERR
1761       integer status(MPI_STATUS_SIZE)
1762 #endif
1763       include 'COMMON.IOUNITS'
1764       include 'COMMON.GEO'
1765       include 'COMMON.VAR'
1766       include 'COMMON.LOCAL'
1767       include 'COMMON.CHAIN'
1768       include 'COMMON.DERIV'
1769       include 'COMMON.INTERACT'
1770       include 'COMMON.CONTACTS'
1771       include 'COMMON.TORSION'
1772       include 'COMMON.VECTORS'
1773       include 'COMMON.FFIELD'
1774       double precision auxvec(2),auxmat(2,2)
1775 C
1776 C Compute the virtual-bond-torsional-angle dependent quantities needed
1777 C to calculate the el-loc multibody terms of various order.
1778 C
1779 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1780       do i=3,nres+1
1781         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1782           iti = itype2loc(itype(i-2))
1783         else
1784           iti=nloctyp
1785         endif
1786 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1787         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1788           iti1 = itype2loc(itype(i-1))
1789         else
1790           iti1=nloctyp
1791         endif
1792 #ifdef NEWCORR
1793         cost1=dcos(theta(i-1))
1794         sint1=dsin(theta(i-1))
1795         sint1sq=sint1*sint1
1796         sint1cub=sint1sq*sint1
1797         sint1cost1=2*sint1*cost1
1798 #ifdef DEBUG
1799         write (iout,*) "bnew1",i,iti
1800         write (iout,*) (bnew1(k,1,iti),k=1,3)
1801         write (iout,*) (bnew1(k,2,iti),k=1,3)
1802         write (iout,*) "bnew2",i,iti
1803         write (iout,*) (bnew2(k,1,iti),k=1,3)
1804         write (iout,*) (bnew2(k,2,iti),k=1,3)
1805 #endif
1806         do k=1,2
1807           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1808           b1(k,i-2)=sint1*b1k
1809           gtb1(k,i-2)=cost1*b1k-sint1sq*
1810      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1811           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1812           b2(k,i-2)=sint1*b2k
1813           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1814      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1815         enddo
1816         do k=1,2
1817           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1818           cc(1,k,i-2)=sint1sq*aux
1819           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1820      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1821           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1822           dd(1,k,i-2)=sint1sq*aux
1823           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1824      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1825         enddo
1826         cc(2,1,i-2)=cc(1,2,i-2)
1827         cc(2,2,i-2)=-cc(1,1,i-2)
1828         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1829         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1830         dd(2,1,i-2)=dd(1,2,i-2)
1831         dd(2,2,i-2)=-dd(1,1,i-2)
1832         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1833         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1834         do k=1,2
1835           do l=1,2
1836             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1837             EE(l,k,i-2)=sint1sq*aux
1838             if (calc_grad)
1839      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1840           enddo
1841         enddo
1842         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1843         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1844         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1845         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1846         if (calc_grad) then
1847         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1848         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1849         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1850         endif
1851 c        b1tilde(1,i-2)=b1(1,i-2)
1852 c        b1tilde(2,i-2)=-b1(2,i-2)
1853 c        b2tilde(1,i-2)=b2(1,i-2)
1854 c        b2tilde(2,i-2)=-b2(2,i-2)
1855 #ifdef DEBUG
1856         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1857         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1858         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1859         write (iout,*) 'theta=', theta(i-1)
1860 #endif
1861 #else
1862 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1863 c          iti = itype2loc(itype(i-2))
1864 c        else
1865 c          iti=nloctyp
1866 c        endif
1867 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1868 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1869 c          iti1 = itype2loc(itype(i-1))
1870 c        else
1871 c          iti1=nloctyp
1872 c        endif
1873         b1(1,i-2)=b(3,iti)
1874         b1(2,i-2)=b(5,iti)
1875         b2(1,i-2)=b(2,iti)
1876         b2(2,i-2)=b(4,iti)
1877         do k=1,2
1878           do l=1,2
1879            CC(k,l,i-2)=ccold(k,l,iti)
1880            DD(k,l,i-2)=ddold(k,l,iti)
1881            EE(k,l,i-2)=eeold(k,l,iti)
1882           enddo
1883         enddo
1884 #endif
1885         b1tilde(1,i-2)= b1(1,i-2)
1886         b1tilde(2,i-2)=-b1(2,i-2)
1887         b2tilde(1,i-2)= b2(1,i-2)
1888         b2tilde(2,i-2)=-b2(2,i-2)
1889 c
1890         Ctilde(1,1,i-2)= CC(1,1,i-2)
1891         Ctilde(1,2,i-2)= CC(1,2,i-2)
1892         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1893         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1894 c
1895         Dtilde(1,1,i-2)= DD(1,1,i-2)
1896         Dtilde(1,2,i-2)= DD(1,2,i-2)
1897         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1898         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1899 c        write(iout,*) "i",i," iti",iti
1900 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1901 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1902       enddo
1903       do i=3,nres+1
1904         if (i .lt. nres+1) then
1905           sin1=dsin(phi(i))
1906           cos1=dcos(phi(i))
1907           sintab(i-2)=sin1
1908           costab(i-2)=cos1
1909           obrot(1,i-2)=cos1
1910           obrot(2,i-2)=sin1
1911           sin2=dsin(2*phi(i))
1912           cos2=dcos(2*phi(i))
1913           sintab2(i-2)=sin2
1914           costab2(i-2)=cos2
1915           obrot2(1,i-2)=cos2
1916           obrot2(2,i-2)=sin2
1917           Ug(1,1,i-2)=-cos1
1918           Ug(1,2,i-2)=-sin1
1919           Ug(2,1,i-2)=-sin1
1920           Ug(2,2,i-2)= cos1
1921           Ug2(1,1,i-2)=-cos2
1922           Ug2(1,2,i-2)=-sin2
1923           Ug2(2,1,i-2)=-sin2
1924           Ug2(2,2,i-2)= cos2
1925         else
1926           costab(i-2)=1.0d0
1927           sintab(i-2)=0.0d0
1928           obrot(1,i-2)=1.0d0
1929           obrot(2,i-2)=0.0d0
1930           obrot2(1,i-2)=0.0d0
1931           obrot2(2,i-2)=0.0d0
1932           Ug(1,1,i-2)=1.0d0
1933           Ug(1,2,i-2)=0.0d0
1934           Ug(2,1,i-2)=0.0d0
1935           Ug(2,2,i-2)=1.0d0
1936           Ug2(1,1,i-2)=0.0d0
1937           Ug2(1,2,i-2)=0.0d0
1938           Ug2(2,1,i-2)=0.0d0
1939           Ug2(2,2,i-2)=0.0d0
1940         endif
1941         if (i .gt. 3 .and. i .lt. nres+1) then
1942           obrot_der(1,i-2)=-sin1
1943           obrot_der(2,i-2)= cos1
1944           Ugder(1,1,i-2)= sin1
1945           Ugder(1,2,i-2)=-cos1
1946           Ugder(2,1,i-2)=-cos1
1947           Ugder(2,2,i-2)=-sin1
1948           dwacos2=cos2+cos2
1949           dwasin2=sin2+sin2
1950           obrot2_der(1,i-2)=-dwasin2
1951           obrot2_der(2,i-2)= dwacos2
1952           Ug2der(1,1,i-2)= dwasin2
1953           Ug2der(1,2,i-2)=-dwacos2
1954           Ug2der(2,1,i-2)=-dwacos2
1955           Ug2der(2,2,i-2)=-dwasin2
1956         else
1957           obrot_der(1,i-2)=0.0d0
1958           obrot_der(2,i-2)=0.0d0
1959           Ugder(1,1,i-2)=0.0d0
1960           Ugder(1,2,i-2)=0.0d0
1961           Ugder(2,1,i-2)=0.0d0
1962           Ugder(2,2,i-2)=0.0d0
1963           obrot2_der(1,i-2)=0.0d0
1964           obrot2_der(2,i-2)=0.0d0
1965           Ug2der(1,1,i-2)=0.0d0
1966           Ug2der(1,2,i-2)=0.0d0
1967           Ug2der(2,1,i-2)=0.0d0
1968           Ug2der(2,2,i-2)=0.0d0
1969         endif
1970 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1971         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1972           iti = itype2loc(itype(i-2))
1973         else
1974           iti=nloctyp
1975         endif
1976 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1977         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1978           iti1 = itype2loc(itype(i-1))
1979         else
1980           iti1=nloctyp
1981         endif
1982 cd        write (iout,*) '*******i',i,' iti1',iti
1983 cd        write (iout,*) 'b1',b1(:,iti)
1984 cd        write (iout,*) 'b2',b2(:,iti)
1985 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1986 c        if (i .gt. iatel_s+2) then
1987         if (i .gt. nnt+2) then
1988           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1989 #ifdef NEWCORR
1990           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1991 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1992 #endif
1993 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1994 c     &    EE(1,2,iti),EE(2,2,i)
1995           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1996           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1997 c          write(iout,*) "Macierz EUG",
1998 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1999 c     &    eug(2,2,i-2)
2000           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2001      &    then
2002           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2003           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2004           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2005           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2006           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2007           endif
2008         else
2009           do k=1,2
2010             Ub2(k,i-2)=0.0d0
2011             Ctobr(k,i-2)=0.0d0
2012             Dtobr2(k,i-2)=0.0d0
2013             do l=1,2
2014               EUg(l,k,i-2)=0.0d0
2015               CUg(l,k,i-2)=0.0d0
2016               DUg(l,k,i-2)=0.0d0
2017               DtUg2(l,k,i-2)=0.0d0
2018             enddo
2019           enddo
2020         endif
2021         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2022         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2023         do k=1,2
2024           muder(k,i-2)=Ub2der(k,i-2)
2025         enddo
2026 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2027         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2028           if (itype(i-1).le.ntyp) then
2029             iti1 = itype2loc(itype(i-1))
2030           else
2031             iti1=nloctyp
2032           endif
2033         else
2034           iti1=nloctyp
2035         endif
2036         do k=1,2
2037           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2038         enddo
2039 #ifdef MUOUT
2040         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2041      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2042      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2043      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2044      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2045      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2046 #endif
2047 cd        write (iout,*) 'mu1',mu1(:,i-2)
2048 cd        write (iout,*) 'mu2',mu2(:,i-2)
2049         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2050      &  then
2051         if (calc_grad) then
2052         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2053         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2054         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2055         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2056         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2057         endif
2058 C Vectors and matrices dependent on a single virtual-bond dihedral.
2059         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2060         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2061         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2062         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2063         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2064         if (calc_grad) then
2065         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2066         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2067         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2068         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2069         endif
2070         endif
2071       enddo
2072 C Matrices dependent on two consecutive virtual-bond dihedrals.
2073 C The order of matrices is from left to right.
2074       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2075      &then
2076       do i=2,nres-1
2077         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2078         if (calc_grad) then
2079         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2080         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2081         endif
2082         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2083         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2084         if (calc_grad) then
2085         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2086         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2087         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2088         endif
2089       enddo
2090       endif
2091       return
2092       end
2093 C--------------------------------------------------------------------------
2094       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2095 C
2096 C This subroutine calculates the average interaction energy and its gradient
2097 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2098 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2099 C The potential depends both on the distance of peptide-group centers and on
2100 C the orientation of the CA-CA virtual bonds.
2101 C
2102       implicit real*8 (a-h,o-z)
2103 #ifdef MPI
2104       include 'mpif.h'
2105 #endif
2106       include 'DIMENSIONS'
2107       include 'COMMON.CONTROL'
2108       include 'COMMON.IOUNITS'
2109       include 'COMMON.GEO'
2110       include 'COMMON.VAR'
2111       include 'COMMON.LOCAL'
2112       include 'COMMON.CHAIN'
2113       include 'COMMON.DERIV'
2114       include 'COMMON.INTERACT'
2115       include 'COMMON.CONTACTS'
2116       include 'COMMON.TORSION'
2117       include 'COMMON.VECTORS'
2118       include 'COMMON.FFIELD'
2119       include 'COMMON.TIME1'
2120       include 'COMMON.SPLITELE'
2121       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2122      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2123       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2124      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2125       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2126      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2127      &    num_conti,j1,j2
2128 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2129 #ifdef MOMENT
2130       double precision scal_el /1.0d0/
2131 #else
2132       double precision scal_el /0.5d0/
2133 #endif
2134 C 12/13/98
2135 C 13-go grudnia roku pamietnego...
2136       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2137      &                   0.0d0,1.0d0,0.0d0,
2138      &                   0.0d0,0.0d0,1.0d0/
2139 cd      write(iout,*) 'In EELEC'
2140 cd      do i=1,nloctyp
2141 cd        write(iout,*) 'Type',i
2142 cd        write(iout,*) 'B1',B1(:,i)
2143 cd        write(iout,*) 'B2',B2(:,i)
2144 cd        write(iout,*) 'CC',CC(:,:,i)
2145 cd        write(iout,*) 'DD',DD(:,:,i)
2146 cd        write(iout,*) 'EE',EE(:,:,i)
2147 cd      enddo
2148 cd      call check_vecgrad
2149 cd      stop
2150       if (icheckgrad.eq.1) then
2151         do i=1,nres-1
2152           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2153           do k=1,3
2154             dc_norm(k,i)=dc(k,i)*fac
2155           enddo
2156 c          write (iout,*) 'i',i,' fac',fac
2157         enddo
2158       endif
2159       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2160      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2161      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2162 c        call vec_and_deriv
2163 #ifdef TIMING
2164         time01=MPI_Wtime()
2165 #endif
2166         call set_matrices
2167 #ifdef TIMING
2168         time_mat=time_mat+MPI_Wtime()-time01
2169 #endif
2170       endif
2171 cd      do i=1,nres-1
2172 cd        write (iout,*) 'i=',i
2173 cd        do k=1,3
2174 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2175 cd        enddo
2176 cd        do k=1,3
2177 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2178 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2179 cd        enddo
2180 cd      enddo
2181       t_eelecij=0.0d0
2182       ees=0.0D0
2183       evdw1=0.0D0
2184       eel_loc=0.0d0
2185       eello_turn3=0.0d0
2186       eello_turn4=0.0d0
2187       ind=0
2188       do i=1,nres
2189         num_cont_hb(i)=0
2190       enddo
2191 cd      print '(a)','Enter EELEC'
2192 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2193 c      call flush(iout)
2194       do i=1,nres
2195         gel_loc_loc(i)=0.0d0
2196         gcorr_loc(i)=0.0d0
2197       enddo
2198 c
2199 c
2200 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2201 C
2202 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2203 C
2204 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2205       do i=iturn3_start,iturn3_end
2206 c        if (i.le.1) cycle
2207 C        write(iout,*) "tu jest i",i
2208         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2209 C changes suggested by Ana to avoid out of bounds
2210 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2211 c     & .or.((i+4).gt.nres)
2212 c     & .or.((i-1).le.0)
2213 C end of changes by Ana
2214 C dobra zmiana wycofana
2215      &  .or. itype(i+2).eq.ntyp1
2216      &  .or. itype(i+3).eq.ntyp1) cycle
2217 C Adam: Instructions below will switch off existing interactions
2218 c        if(i.gt.1)then
2219 c          if(itype(i-1).eq.ntyp1)cycle
2220 c        end if
2221 c        if(i.LT.nres-3)then
2222 c          if (itype(i+4).eq.ntyp1) cycle
2223 c        end if
2224         dxi=dc(1,i)
2225         dyi=dc(2,i)
2226         dzi=dc(3,i)
2227         dx_normi=dc_norm(1,i)
2228         dy_normi=dc_norm(2,i)
2229         dz_normi=dc_norm(3,i)
2230         xmedi=c(1,i)+0.5d0*dxi
2231         ymedi=c(2,i)+0.5d0*dyi
2232         zmedi=c(3,i)+0.5d0*dzi
2233           xmedi=mod(xmedi,boxxsize)
2234           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2235           ymedi=mod(ymedi,boxysize)
2236           if (ymedi.lt.0) ymedi=ymedi+boxysize
2237           zmedi=mod(zmedi,boxzsize)
2238           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2239         num_conti=0
2240         call eelecij(i,i+2,ees,evdw1,eel_loc)
2241         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2242         num_cont_hb(i)=num_conti
2243       enddo
2244       do i=iturn4_start,iturn4_end
2245         if (i.lt.1) cycle
2246         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2247 C changes suggested by Ana to avoid out of bounds
2248 c     & .or.((i+5).gt.nres)
2249 c     & .or.((i-1).le.0)
2250 C end of changes suggested by Ana
2251      &    .or. itype(i+3).eq.ntyp1
2252      &    .or. itype(i+4).eq.ntyp1
2253 c     &    .or. itype(i+5).eq.ntyp1
2254 c     &    .or. itype(i).eq.ntyp1
2255 c     &    .or. itype(i-1).eq.ntyp1
2256      &                             ) cycle
2257         dxi=dc(1,i)
2258         dyi=dc(2,i)
2259         dzi=dc(3,i)
2260         dx_normi=dc_norm(1,i)
2261         dy_normi=dc_norm(2,i)
2262         dz_normi=dc_norm(3,i)
2263         xmedi=c(1,i)+0.5d0*dxi
2264         ymedi=c(2,i)+0.5d0*dyi
2265         zmedi=c(3,i)+0.5d0*dzi
2266 C Return atom into box, boxxsize is size of box in x dimension
2267 c  194   continue
2268 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2269 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2270 C Condition for being inside the proper box
2271 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2272 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2273 c        go to 194
2274 c        endif
2275 c  195   continue
2276 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2277 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2278 C Condition for being inside the proper box
2279 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2280 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2281 c        go to 195
2282 c        endif
2283 c  196   continue
2284 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2285 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2286 C Condition for being inside the proper box
2287 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2288 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2289 c        go to 196
2290 c        endif
2291           xmedi=mod(xmedi,boxxsize)
2292           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2293           ymedi=mod(ymedi,boxysize)
2294           if (ymedi.lt.0) ymedi=ymedi+boxysize
2295           zmedi=mod(zmedi,boxzsize)
2296           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2297
2298         num_conti=num_cont_hb(i)
2299 c        write(iout,*) "JESTEM W PETLI"
2300         call eelecij(i,i+3,ees,evdw1,eel_loc)
2301         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2302      &   call eturn4(i,eello_turn4)
2303         num_cont_hb(i)=num_conti
2304       enddo   ! i
2305 C Loop over all neighbouring boxes
2306 C      do xshift=-1,1
2307 C      do yshift=-1,1
2308 C      do zshift=-1,1
2309 c
2310 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2311 c
2312 CTU KURWA
2313       do i=iatel_s,iatel_e
2314 C        do i=75,75
2315 c        if (i.le.1) cycle
2316         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2317 C changes suggested by Ana to avoid out of bounds
2318 c     & .or.((i+2).gt.nres)
2319 c     & .or.((i-1).le.0)
2320 C end of changes by Ana
2321 c     &  .or. itype(i+2).eq.ntyp1
2322 c     &  .or. itype(i-1).eq.ntyp1
2323      &                ) cycle
2324         dxi=dc(1,i)
2325         dyi=dc(2,i)
2326         dzi=dc(3,i)
2327         dx_normi=dc_norm(1,i)
2328         dy_normi=dc_norm(2,i)
2329         dz_normi=dc_norm(3,i)
2330         xmedi=c(1,i)+0.5d0*dxi
2331         ymedi=c(2,i)+0.5d0*dyi
2332         zmedi=c(3,i)+0.5d0*dzi
2333           xmedi=mod(xmedi,boxxsize)
2334           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2335           ymedi=mod(ymedi,boxysize)
2336           if (ymedi.lt.0) ymedi=ymedi+boxysize
2337           zmedi=mod(zmedi,boxzsize)
2338           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2339 C          xmedi=xmedi+xshift*boxxsize
2340 C          ymedi=ymedi+yshift*boxysize
2341 C          zmedi=zmedi+zshift*boxzsize
2342
2343 C Return tom into box, boxxsize is size of box in x dimension
2344 c  164   continue
2345 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2346 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2347 C Condition for being inside the proper box
2348 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2349 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2350 c        go to 164
2351 c        endif
2352 c  165   continue
2353 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2354 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2355 C Condition for being inside the proper box
2356 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2357 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2358 c        go to 165
2359 c        endif
2360 c  166   continue
2361 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2362 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2363 cC Condition for being inside the proper box
2364 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2365 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2366 c        go to 166
2367 c        endif
2368
2369 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2370         num_conti=num_cont_hb(i)
2371 C I TU KURWA
2372         do j=ielstart(i),ielend(i)
2373 C          do j=16,17
2374 C          write (iout,*) i,j
2375 C         if (j.le.1) cycle
2376           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2377 C changes suggested by Ana to avoid out of bounds
2378 c     & .or.((j+2).gt.nres)
2379 c     & .or.((j-1).le.0)
2380 C end of changes by Ana
2381 c     & .or.itype(j+2).eq.ntyp1
2382 c     & .or.itype(j-1).eq.ntyp1
2383      &) cycle
2384           call eelecij(i,j,ees,evdw1,eel_loc)
2385         enddo ! j
2386         num_cont_hb(i)=num_conti
2387       enddo   ! i
2388 C     enddo   ! zshift
2389 C      enddo   ! yshift
2390 C      enddo   ! xshift
2391
2392 c      write (iout,*) "Number of loop steps in EELEC:",ind
2393 cd      do i=1,nres
2394 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2395 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2396 cd      enddo
2397 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2398 ccc      eel_loc=eel_loc+eello_turn3
2399 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2400       return
2401       end
2402 C-------------------------------------------------------------------------------
2403       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2404       implicit real*8 (a-h,o-z)
2405       include 'DIMENSIONS'
2406 #ifdef MPI
2407       include "mpif.h"
2408 #endif
2409       include 'COMMON.CONTROL'
2410       include 'COMMON.IOUNITS'
2411       include 'COMMON.GEO'
2412       include 'COMMON.VAR'
2413       include 'COMMON.LOCAL'
2414       include 'COMMON.CHAIN'
2415       include 'COMMON.DERIV'
2416       include 'COMMON.INTERACT'
2417       include 'COMMON.CONTACTS'
2418       include 'COMMON.TORSION'
2419       include 'COMMON.VECTORS'
2420       include 'COMMON.FFIELD'
2421       include 'COMMON.TIME1'
2422       include 'COMMON.SPLITELE'
2423       include 'COMMON.SHIELD'
2424       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2425      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2426       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2427      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2428      &    gmuij2(4),gmuji2(4)
2429       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2430      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2431      &    num_conti,j1,j2
2432 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2433 #ifdef MOMENT
2434       double precision scal_el /1.0d0/
2435 #else
2436       double precision scal_el /0.5d0/
2437 #endif
2438 C 12/13/98
2439 C 13-go grudnia roku pamietnego...
2440       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2441      &                   0.0d0,1.0d0,0.0d0,
2442      &                   0.0d0,0.0d0,1.0d0/
2443        integer xshift,yshift,zshift
2444 c          time00=MPI_Wtime()
2445 cd      write (iout,*) "eelecij",i,j
2446 c          ind=ind+1
2447           iteli=itel(i)
2448           itelj=itel(j)
2449           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2450           aaa=app(iteli,itelj)
2451           bbb=bpp(iteli,itelj)
2452           ael6i=ael6(iteli,itelj)
2453           ael3i=ael3(iteli,itelj)
2454           dxj=dc(1,j)
2455           dyj=dc(2,j)
2456           dzj=dc(3,j)
2457           dx_normj=dc_norm(1,j)
2458           dy_normj=dc_norm(2,j)
2459           dz_normj=dc_norm(3,j)
2460 C          xj=c(1,j)+0.5D0*dxj-xmedi
2461 C          yj=c(2,j)+0.5D0*dyj-ymedi
2462 C          zj=c(3,j)+0.5D0*dzj-zmedi
2463           xj=c(1,j)+0.5D0*dxj
2464           yj=c(2,j)+0.5D0*dyj
2465           zj=c(3,j)+0.5D0*dzj
2466           xj=mod(xj,boxxsize)
2467           if (xj.lt.0) xj=xj+boxxsize
2468           yj=mod(yj,boxysize)
2469           if (yj.lt.0) yj=yj+boxysize
2470           zj=mod(zj,boxzsize)
2471           if (zj.lt.0) zj=zj+boxzsize
2472           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2473       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2474       xj_safe=xj
2475       yj_safe=yj
2476       zj_safe=zj
2477       isubchap=0
2478       do xshift=-1,1
2479       do yshift=-1,1
2480       do zshift=-1,1
2481           xj=xj_safe+xshift*boxxsize
2482           yj=yj_safe+yshift*boxysize
2483           zj=zj_safe+zshift*boxzsize
2484           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2485           if(dist_temp.lt.dist_init) then
2486             dist_init=dist_temp
2487             xj_temp=xj
2488             yj_temp=yj
2489             zj_temp=zj
2490             isubchap=1
2491           endif
2492        enddo
2493        enddo
2494        enddo
2495        if (isubchap.eq.1) then
2496           xj=xj_temp-xmedi
2497           yj=yj_temp-ymedi
2498           zj=zj_temp-zmedi
2499        else
2500           xj=xj_safe-xmedi
2501           yj=yj_safe-ymedi
2502           zj=zj_safe-zmedi
2503        endif
2504 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2505 c  174   continue
2506 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2507 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2508 C Condition for being inside the proper box
2509 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2510 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2511 c        go to 174
2512 c        endif
2513 c  175   continue
2514 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2515 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2516 C Condition for being inside the proper box
2517 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2518 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2519 c        go to 175
2520 c        endif
2521 c  176   continue
2522 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2523 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2524 C Condition for being inside the proper box
2525 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2526 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2527 c        go to 176
2528 c        endif
2529 C        endif !endPBC condintion
2530 C        xj=xj-xmedi
2531 C        yj=yj-ymedi
2532 C        zj=zj-zmedi
2533           rij=xj*xj+yj*yj+zj*zj
2534
2535             sss=sscale(sqrt(rij))
2536             sssgrad=sscagrad(sqrt(rij))
2537 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2538 c     &       " rlamb",rlamb," sss",sss
2539 c            if (sss.gt.0.0d0) then
2540           rrmij=1.0D0/rij
2541           rij=dsqrt(rij)
2542           rmij=1.0D0/rij
2543           r3ij=rrmij*rmij
2544           r6ij=r3ij*r3ij
2545           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2546           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2547           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2548           fac=cosa-3.0D0*cosb*cosg
2549           ev1=aaa*r6ij*r6ij
2550 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2551           if (j.eq.i+2) ev1=scal_el*ev1
2552           ev2=bbb*r6ij
2553           fac3=ael6i*r6ij
2554           fac4=ael3i*r3ij
2555           evdwij=(ev1+ev2)
2556           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2557           el2=fac4*fac
2558 C MARYSIA
2559 C          eesij=(el1+el2)
2560 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2561           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2562           if (shield_mode.gt.0) then
2563 C          fac_shield(i)=0.4
2564 C          fac_shield(j)=0.6
2565           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2566           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2567           eesij=(el1+el2)
2568           ees=ees+eesij
2569           else
2570           fac_shield(i)=1.0
2571           fac_shield(j)=1.0
2572           eesij=(el1+el2)
2573           ees=ees+eesij
2574           endif
2575           evdw1=evdw1+evdwij*sss
2576 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2577 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2578 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2579 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2580
2581           if (energy_dec) then
2582               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2583      &'evdw1',i,j,evdwij
2584      &,iteli,itelj,aaa,evdw1,sss
2585               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2586      &fac_shield(i),fac_shield(j)
2587           endif
2588
2589 C
2590 C Calculate contributions to the Cartesian gradient.
2591 C
2592 #ifdef SPLITELE
2593           facvdw=-6*rrmij*(ev1+evdwij)*sss
2594           facel=-3*rrmij*(el1+eesij)
2595           fac1=fac
2596           erij(1)=xj*rmij
2597           erij(2)=yj*rmij
2598           erij(3)=zj*rmij
2599
2600 *
2601 * Radial derivatives. First process both termini of the fragment (i,j)
2602 *
2603           if (calc_grad) then
2604           ggg(1)=facel*xj
2605           ggg(2)=facel*yj
2606           ggg(3)=facel*zj
2607           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2608      &  (shield_mode.gt.0)) then
2609 C          print *,i,j
2610           do ilist=1,ishield_list(i)
2611            iresshield=shield_list(ilist,i)
2612            do k=1,3
2613            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2614      &      *2.0
2615            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2616      &              rlocshield
2617      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2618             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2619 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2620 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2621 C             if (iresshield.gt.i) then
2622 C               do ishi=i+1,iresshield-1
2623 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2624 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2625 C
2626 C              enddo
2627 C             else
2628 C               do ishi=iresshield,i
2629 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2630 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2631 C
2632 C               enddo
2633 C              endif
2634            enddo
2635           enddo
2636           do ilist=1,ishield_list(j)
2637            iresshield=shield_list(ilist,j)
2638            do k=1,3
2639            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2640      &     *2.0
2641            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2642      &              rlocshield
2643      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2644            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2645
2646 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2647 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2648 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2649 C             if (iresshield.gt.j) then
2650 C               do ishi=j+1,iresshield-1
2651 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2652 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2653 C
2654 C               enddo
2655 C            else
2656 C               do ishi=iresshield,j
2657 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2658 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2659 C               enddo
2660 C              endif
2661            enddo
2662           enddo
2663
2664           do k=1,3
2665             gshieldc(k,i)=gshieldc(k,i)+
2666      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2667             gshieldc(k,j)=gshieldc(k,j)+
2668      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2669             gshieldc(k,i-1)=gshieldc(k,i-1)+
2670      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2671             gshieldc(k,j-1)=gshieldc(k,j-1)+
2672      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2673
2674            enddo
2675            endif
2676 c          do k=1,3
2677 c            ghalf=0.5D0*ggg(k)
2678 c            gelc(k,i)=gelc(k,i)+ghalf
2679 c            gelc(k,j)=gelc(k,j)+ghalf
2680 c          enddo
2681 c 9/28/08 AL Gradient compotents will be summed only at the end
2682 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2683           do k=1,3
2684             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2685 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2686             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2687 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2688 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2689 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2690 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2691 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2692           enddo
2693 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2694
2695 *
2696 * Loop over residues i+1 thru j-1.
2697 *
2698 cgrad          do k=i+1,j-1
2699 cgrad            do l=1,3
2700 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2701 cgrad            enddo
2702 cgrad          enddo
2703           if (sss.gt.0.0) then
2704           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2705           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2706           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2707           else
2708           ggg(1)=0.0
2709           ggg(2)=0.0
2710           ggg(3)=0.0
2711           endif
2712 c          do k=1,3
2713 c            ghalf=0.5D0*ggg(k)
2714 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2715 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2716 c          enddo
2717 c 9/28/08 AL Gradient compotents will be summed only at the end
2718           do k=1,3
2719             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2720             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2721           enddo
2722 *
2723 * Loop over residues i+1 thru j-1.
2724 *
2725 cgrad          do k=i+1,j-1
2726 cgrad            do l=1,3
2727 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2728 cgrad            enddo
2729 cgrad          enddo
2730           endif ! calc_grad
2731 #else
2732 C MARYSIA
2733           facvdw=(ev1+evdwij)*sss
2734           facel=(el1+eesij)
2735           fac1=fac
2736           fac=-3*rrmij*(facvdw+facvdw+facel)
2737           erij(1)=xj*rmij
2738           erij(2)=yj*rmij
2739           erij(3)=zj*rmij
2740 *
2741 * Radial derivatives. First process both termini of the fragment (i,j)
2742 *
2743           if (calc_grad) then
2744           ggg(1)=fac*xj
2745 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2746           ggg(2)=fac*yj
2747 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2748           ggg(3)=fac*zj
2749 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2750 c          do k=1,3
2751 c            ghalf=0.5D0*ggg(k)
2752 c            gelc(k,i)=gelc(k,i)+ghalf
2753 c            gelc(k,j)=gelc(k,j)+ghalf
2754 c          enddo
2755 c 9/28/08 AL Gradient compotents will be summed only at the end
2756           do k=1,3
2757             gelc_long(k,j)=gelc(k,j)+ggg(k)
2758             gelc_long(k,i)=gelc(k,i)-ggg(k)
2759           enddo
2760 *
2761 * Loop over residues i+1 thru j-1.
2762 *
2763 cgrad          do k=i+1,j-1
2764 cgrad            do l=1,3
2765 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2766 cgrad            enddo
2767 cgrad          enddo
2768 c 9/28/08 AL Gradient compotents will be summed only at the end
2769           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2770           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2771           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2772           do k=1,3
2773             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2774             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2775           enddo
2776           endif ! calc_grad
2777 #endif
2778 *
2779 * Angular part
2780 *
2781           if (calc_grad) then
2782           ecosa=2.0D0*fac3*fac1+fac4
2783           fac4=-3.0D0*fac4
2784           fac3=-6.0D0*fac3
2785           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2786           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2787           do k=1,3
2788             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2789             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2790           enddo
2791 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2792 cd   &          (dcosg(k),k=1,3)
2793           do k=1,3
2794             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2795      &      fac_shield(i)**2*fac_shield(j)**2
2796           enddo
2797 c          do k=1,3
2798 c            ghalf=0.5D0*ggg(k)
2799 c            gelc(k,i)=gelc(k,i)+ghalf
2800 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2801 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2802 c            gelc(k,j)=gelc(k,j)+ghalf
2803 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2804 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2805 c          enddo
2806 cgrad          do k=i+1,j-1
2807 cgrad            do l=1,3
2808 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2809 cgrad            enddo
2810 cgrad          enddo
2811 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2812           do k=1,3
2813             gelc(k,i)=gelc(k,i)
2814      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2815      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2816      &           *fac_shield(i)**2*fac_shield(j)**2
2817             gelc(k,j)=gelc(k,j)
2818      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2819      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2820      &           *fac_shield(i)**2*fac_shield(j)**2
2821             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2822             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2823           enddo
2824 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2825
2826 C MARYSIA
2827 c          endif !sscale
2828           endif ! calc_grad
2829           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2830      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2831      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2832 C
2833 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2834 C   energy of a peptide unit is assumed in the form of a second-order
2835 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2836 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2837 C   are computed for EVERY pair of non-contiguous peptide groups.
2838 C
2839
2840           if (j.lt.nres-1) then
2841             j1=j+1
2842             j2=j-1
2843           else
2844             j1=j-1
2845             j2=j-2
2846           endif
2847           kkk=0
2848           lll=0
2849           do k=1,2
2850             do l=1,2
2851               kkk=kkk+1
2852               muij(kkk)=mu(k,i)*mu(l,j)
2853 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2854 #ifdef NEWCORR
2855              if (calc_grad) then
2856              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2857 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2858              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2859              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2860 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2861              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2862              endif
2863 #endif
2864             enddo
2865           enddo
2866 #ifdef DEBUG
2867           write (iout,*) 'EELEC: i',i,' j',j
2868           write (iout,*) 'j',j,' j1',j1,' j2',j2
2869           write(iout,*) 'muij',muij
2870           write (iout,*) "uy",uy(:,i)
2871           write (iout,*) "uz",uz(:,j)
2872           write (iout,*) "erij",erij
2873 #endif
2874           ury=scalar(uy(1,i),erij)
2875           urz=scalar(uz(1,i),erij)
2876           vry=scalar(uy(1,j),erij)
2877           vrz=scalar(uz(1,j),erij)
2878           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2879           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2880           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2881           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2882           fac=dsqrt(-ael6i)*r3ij
2883           a22=a22*fac
2884           a23=a23*fac
2885           a32=a32*fac
2886           a33=a33*fac
2887 cd          write (iout,'(4i5,4f10.5)')
2888 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2889 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2890 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2891 cd     &      uy(:,j),uz(:,j)
2892 cd          write (iout,'(4f10.5)')
2893 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2894 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2895 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2896 cd           write (iout,'(9f10.5/)')
2897 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2898 C Derivatives of the elements of A in virtual-bond vectors
2899           if (calc_grad) then
2900           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2901           do k=1,3
2902             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2903             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2904             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2905             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2906             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2907             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2908             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2909             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2910             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2911             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2912             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2913             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2914           enddo
2915 C Compute radial contributions to the gradient
2916           facr=-3.0d0*rrmij
2917           a22der=a22*facr
2918           a23der=a23*facr
2919           a32der=a32*facr
2920           a33der=a33*facr
2921           agg(1,1)=a22der*xj
2922           agg(2,1)=a22der*yj
2923           agg(3,1)=a22der*zj
2924           agg(1,2)=a23der*xj
2925           agg(2,2)=a23der*yj
2926           agg(3,2)=a23der*zj
2927           agg(1,3)=a32der*xj
2928           agg(2,3)=a32der*yj
2929           agg(3,3)=a32der*zj
2930           agg(1,4)=a33der*xj
2931           agg(2,4)=a33der*yj
2932           agg(3,4)=a33der*zj
2933 C Add the contributions coming from er
2934           fac3=-3.0d0*fac
2935           do k=1,3
2936             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2937             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2938             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2939             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2940           enddo
2941           do k=1,3
2942 C Derivatives in DC(i)
2943 cgrad            ghalf1=0.5d0*agg(k,1)
2944 cgrad            ghalf2=0.5d0*agg(k,2)
2945 cgrad            ghalf3=0.5d0*agg(k,3)
2946 cgrad            ghalf4=0.5d0*agg(k,4)
2947             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2948      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2949             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2950      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2951             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2952      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2953             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2954      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2955 C Derivatives in DC(i+1)
2956             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2957      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2958             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2959      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2960             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2961      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2962             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2963      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2964 C Derivatives in DC(j)
2965             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2966      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2967             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2968      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2969             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2970      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2971             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2972      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2973 C Derivatives in DC(j+1) or DC(nres-1)
2974             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2975      &      -3.0d0*vryg(k,3)*ury)
2976             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2977      &      -3.0d0*vrzg(k,3)*ury)
2978             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2979      &      -3.0d0*vryg(k,3)*urz)
2980             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2981      &      -3.0d0*vrzg(k,3)*urz)
2982 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2983 cgrad              do l=1,4
2984 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2985 cgrad              enddo
2986 cgrad            endif
2987           enddo
2988           endif ! calc_grad
2989           acipa(1,1)=a22
2990           acipa(1,2)=a23
2991           acipa(2,1)=a32
2992           acipa(2,2)=a33
2993           a22=-a22
2994           a23=-a23
2995           if (calc_grad) then
2996           do l=1,2
2997             do k=1,3
2998               agg(k,l)=-agg(k,l)
2999               aggi(k,l)=-aggi(k,l)
3000               aggi1(k,l)=-aggi1(k,l)
3001               aggj(k,l)=-aggj(k,l)
3002               aggj1(k,l)=-aggj1(k,l)
3003             enddo
3004           enddo
3005           endif ! calc_grad
3006           if (j.lt.nres-1) then
3007             a22=-a22
3008             a32=-a32
3009             do l=1,3,2
3010               do k=1,3
3011                 agg(k,l)=-agg(k,l)
3012                 aggi(k,l)=-aggi(k,l)
3013                 aggi1(k,l)=-aggi1(k,l)
3014                 aggj(k,l)=-aggj(k,l)
3015                 aggj1(k,l)=-aggj1(k,l)
3016               enddo
3017             enddo
3018           else
3019             a22=-a22
3020             a23=-a23
3021             a32=-a32
3022             a33=-a33
3023             do l=1,4
3024               do k=1,3
3025                 agg(k,l)=-agg(k,l)
3026                 aggi(k,l)=-aggi(k,l)
3027                 aggi1(k,l)=-aggi1(k,l)
3028                 aggj(k,l)=-aggj(k,l)
3029                 aggj1(k,l)=-aggj1(k,l)
3030               enddo
3031             enddo
3032           endif
3033           ENDIF ! WCORR
3034           IF (wel_loc.gt.0.0d0) THEN
3035 C Contribution to the local-electrostatic energy coming from the i-j pair
3036           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3037      &     +a33*muij(4)
3038 #ifdef DEBUG
3039           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3040      &     " a33",a33
3041           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3042      &     " wel_loc",wel_loc
3043 #endif
3044           if (shield_mode.eq.0) then
3045            fac_shield(i)=1.0
3046            fac_shield(j)=1.0
3047 C          else
3048 C           fac_shield(i)=0.4
3049 C           fac_shield(j)=0.6
3050           endif
3051           eel_loc_ij=eel_loc_ij
3052      &    *fac_shield(i)*fac_shield(j)
3053           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3054      &            'eelloc',i,j,eel_loc_ij
3055 c           if (eel_loc_ij.ne.0)
3056 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3057 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3058
3059           eel_loc=eel_loc+eel_loc_ij
3060 C Now derivative over eel_loc
3061           if (calc_grad) then
3062           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3063      &  (shield_mode.gt.0)) then
3064 C          print *,i,j
3065
3066           do ilist=1,ishield_list(i)
3067            iresshield=shield_list(ilist,i)
3068            do k=1,3
3069            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3070      &                                          /fac_shield(i)
3071 C     &      *2.0
3072            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3073      &              rlocshield
3074      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3075             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3076      &      +rlocshield
3077            enddo
3078           enddo
3079           do ilist=1,ishield_list(j)
3080            iresshield=shield_list(ilist,j)
3081            do k=1,3
3082            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3083      &                                       /fac_shield(j)
3084 C     &     *2.0
3085            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3086      &              rlocshield
3087      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3088            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3089      &             +rlocshield
3090
3091            enddo
3092           enddo
3093
3094           do k=1,3
3095             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3096      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3097             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3098      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3099             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3100      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3101             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3102      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3103            enddo
3104            endif
3105
3106
3107 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3108 c     &                     ' eel_loc_ij',eel_loc_ij
3109 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3110 C Calculate patrial derivative for theta angle
3111 #ifdef NEWCORR
3112          geel_loc_ij=(a22*gmuij1(1)
3113      &     +a23*gmuij1(2)
3114      &     +a32*gmuij1(3)
3115      &     +a33*gmuij1(4))
3116      &    *fac_shield(i)*fac_shield(j)
3117 c         write(iout,*) "derivative over thatai"
3118 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3119 c     &   a33*gmuij1(4)
3120          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3121      &      geel_loc_ij*wel_loc
3122 c         write(iout,*) "derivative over thatai-1"
3123 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3124 c     &   a33*gmuij2(4)
3125          geel_loc_ij=
3126      &     a22*gmuij2(1)
3127      &     +a23*gmuij2(2)
3128      &     +a32*gmuij2(3)
3129      &     +a33*gmuij2(4)
3130          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3131      &      geel_loc_ij*wel_loc
3132      &    *fac_shield(i)*fac_shield(j)
3133
3134 c  Derivative over j residue
3135          geel_loc_ji=a22*gmuji1(1)
3136      &     +a23*gmuji1(2)
3137      &     +a32*gmuji1(3)
3138      &     +a33*gmuji1(4)
3139 c         write(iout,*) "derivative over thataj"
3140 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3141 c     &   a33*gmuji1(4)
3142
3143         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3144      &      geel_loc_ji*wel_loc
3145      &    *fac_shield(i)*fac_shield(j)
3146
3147          geel_loc_ji=
3148      &     +a22*gmuji2(1)
3149      &     +a23*gmuji2(2)
3150      &     +a32*gmuji2(3)
3151      &     +a33*gmuji2(4)
3152 c         write(iout,*) "derivative over thataj-1"
3153 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3154 c     &   a33*gmuji2(4)
3155          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3156      &      geel_loc_ji*wel_loc
3157      &    *fac_shield(i)*fac_shield(j)
3158 #endif
3159 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3160
3161 C Partial derivatives in virtual-bond dihedral angles gamma
3162           if (i.gt.1)
3163      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3164      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3165      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3166      &    *fac_shield(i)*fac_shield(j)
3167
3168           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3169      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3170      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3171      &    *fac_shield(i)*fac_shield(j)
3172 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3173           do l=1,3
3174             ggg(l)=(agg(l,1)*muij(1)+
3175      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3176      &    *fac_shield(i)*fac_shield(j)
3177             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3178             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3179 cgrad            ghalf=0.5d0*ggg(l)
3180 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3181 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3182           enddo
3183 cgrad          do k=i+1,j2
3184 cgrad            do l=1,3
3185 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3186 cgrad            enddo
3187 cgrad          enddo
3188 C Remaining derivatives of eello
3189           do l=1,3
3190             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3191      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3192      &    *fac_shield(i)*fac_shield(j)
3193
3194             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3195      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3196      &    *fac_shield(i)*fac_shield(j)
3197
3198             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3199      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3200      &    *fac_shield(i)*fac_shield(j)
3201
3202             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3203      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3204      &    *fac_shield(i)*fac_shield(j)
3205
3206           enddo
3207           endif ! calc_grad
3208           ENDIF
3209
3210
3211 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3212 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3213           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3214      &       .and. num_conti.le.maxconts) then
3215 c            write (iout,*) i,j," entered corr"
3216 C
3217 C Calculate the contact function. The ith column of the array JCONT will
3218 C contain the numbers of atoms that make contacts with the atom I (of numbers
3219 C greater than I). The arrays FACONT and GACONT will contain the values of
3220 C the contact function and its derivative.
3221 c           r0ij=1.02D0*rpp(iteli,itelj)
3222 c           r0ij=1.11D0*rpp(iteli,itelj)
3223             r0ij=2.20D0*rpp(iteli,itelj)
3224 c           r0ij=1.55D0*rpp(iteli,itelj)
3225             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3226             if (fcont.gt.0.0D0) then
3227               num_conti=num_conti+1
3228               if (num_conti.gt.maxconts) then
3229                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3230      &                         ' will skip next contacts for this conf.'
3231               else
3232                 jcont_hb(num_conti,i)=j
3233 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3234 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3235                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3236      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3237 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3238 C  terms.
3239                 d_cont(num_conti,i)=rij
3240 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3241 C     --- Electrostatic-interaction matrix ---
3242                 a_chuj(1,1,num_conti,i)=a22
3243                 a_chuj(1,2,num_conti,i)=a23
3244                 a_chuj(2,1,num_conti,i)=a32
3245                 a_chuj(2,2,num_conti,i)=a33
3246 C     --- Gradient of rij
3247                 if (calc_grad) then
3248                 do kkk=1,3
3249                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3250                 enddo
3251                 kkll=0
3252                 do k=1,2
3253                   do l=1,2
3254                     kkll=kkll+1
3255                     do m=1,3
3256                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3257                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3258                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3259                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3260                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3261                     enddo
3262                   enddo
3263                 enddo
3264                 endif ! calc_grad
3265                 ENDIF
3266                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3267 C Calculate contact energies
3268                 cosa4=4.0D0*cosa
3269                 wij=cosa-3.0D0*cosb*cosg
3270                 cosbg1=cosb+cosg
3271                 cosbg2=cosb-cosg
3272 c               fac3=dsqrt(-ael6i)/r0ij**3
3273                 fac3=dsqrt(-ael6i)*r3ij
3274 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3275                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3276                 if (ees0tmp.gt.0) then
3277                   ees0pij=dsqrt(ees0tmp)
3278                 else
3279                   ees0pij=0
3280                 endif
3281 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3282                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3283                 if (ees0tmp.gt.0) then
3284                   ees0mij=dsqrt(ees0tmp)
3285                 else
3286                   ees0mij=0
3287                 endif
3288 c               ees0mij=0.0D0
3289                 if (shield_mode.eq.0) then
3290                 fac_shield(i)=1.0d0
3291                 fac_shield(j)=1.0d0
3292                 else
3293                 ees0plist(num_conti,i)=j
3294 C                fac_shield(i)=0.4d0
3295 C                fac_shield(j)=0.6d0
3296                 endif
3297                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3298      &          *fac_shield(i)*fac_shield(j)
3299                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3300      &          *fac_shield(i)*fac_shield(j)
3301 C Diagnostics. Comment out or remove after debugging!
3302 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3303 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3304 c               ees0m(num_conti,i)=0.0D0
3305 C End diagnostics.
3306 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3307 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3308 C Angular derivatives of the contact function
3309
3310                 ees0pij1=fac3/ees0pij
3311                 ees0mij1=fac3/ees0mij
3312                 fac3p=-3.0D0*fac3*rrmij
3313                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3314                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3315 c               ees0mij1=0.0D0
3316                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3317                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3318                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3319                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3320                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3321                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3322                 ecosap=ecosa1+ecosa2
3323                 ecosbp=ecosb1+ecosb2
3324                 ecosgp=ecosg1+ecosg2
3325                 ecosam=ecosa1-ecosa2
3326                 ecosbm=ecosb1-ecosb2
3327                 ecosgm=ecosg1-ecosg2
3328 C Diagnostics
3329 c               ecosap=ecosa1
3330 c               ecosbp=ecosb1
3331 c               ecosgp=ecosg1
3332 c               ecosam=0.0D0
3333 c               ecosbm=0.0D0
3334 c               ecosgm=0.0D0
3335 C End diagnostics
3336                 facont_hb(num_conti,i)=fcont
3337
3338                 if (calc_grad) then
3339                 fprimcont=fprimcont/rij
3340 cd              facont_hb(num_conti,i)=1.0D0
3341 C Following line is for diagnostics.
3342 cd              fprimcont=0.0D0
3343                 do k=1,3
3344                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3345                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3346                 enddo
3347                 do k=1,3
3348                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3349                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3350                 enddo
3351                 gggp(1)=gggp(1)+ees0pijp*xj
3352                 gggp(2)=gggp(2)+ees0pijp*yj
3353                 gggp(3)=gggp(3)+ees0pijp*zj
3354                 gggm(1)=gggm(1)+ees0mijp*xj
3355                 gggm(2)=gggm(2)+ees0mijp*yj
3356                 gggm(3)=gggm(3)+ees0mijp*zj
3357 C Derivatives due to the contact function
3358                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3359                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3360                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3361                 do k=1,3
3362 c
3363 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3364 c          following the change of gradient-summation algorithm.
3365 c
3366 cgrad                  ghalfp=0.5D0*gggp(k)
3367 cgrad                  ghalfm=0.5D0*gggm(k)
3368                   gacontp_hb1(k,num_conti,i)=!ghalfp
3369      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3370      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3371      &          *fac_shield(i)*fac_shield(j)
3372
3373                   gacontp_hb2(k,num_conti,i)=!ghalfp
3374      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3375      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3376      &          *fac_shield(i)*fac_shield(j)
3377
3378                   gacontp_hb3(k,num_conti,i)=gggp(k)
3379      &          *fac_shield(i)*fac_shield(j)
3380
3381                   gacontm_hb1(k,num_conti,i)=!ghalfm
3382      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3383      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3384      &          *fac_shield(i)*fac_shield(j)
3385
3386                   gacontm_hb2(k,num_conti,i)=!ghalfm
3387      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3388      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3389      &          *fac_shield(i)*fac_shield(j)
3390
3391                   gacontm_hb3(k,num_conti,i)=gggm(k)
3392      &          *fac_shield(i)*fac_shield(j)
3393
3394                 enddo
3395 C Diagnostics. Comment out or remove after debugging!
3396 cdiag           do k=1,3
3397 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3398 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3399 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3400 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3401 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3402 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3403 cdiag           enddo
3404
3405                  endif ! calc_grad
3406
3407               ENDIF ! wcorr
3408               endif  ! num_conti.le.maxconts
3409             endif  ! fcont.gt.0
3410           endif    ! j.gt.i+1
3411           if (calc_grad) then
3412           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3413             do k=1,4
3414               do l=1,3
3415                 ghalf=0.5d0*agg(l,k)
3416                 aggi(l,k)=aggi(l,k)+ghalf
3417                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3418                 aggj(l,k)=aggj(l,k)+ghalf
3419               enddo
3420             enddo
3421             if (j.eq.nres-1 .and. i.lt.j-2) then
3422               do k=1,4
3423                 do l=1,3
3424                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3425                 enddo
3426               enddo
3427             endif
3428           endif
3429           endif ! calc_grad
3430 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3431       return
3432       end
3433 C-----------------------------------------------------------------------------
3434       subroutine eturn3(i,eello_turn3)
3435 C Third- and fourth-order contributions from turns
3436       implicit real*8 (a-h,o-z)
3437       include 'DIMENSIONS'
3438       include 'COMMON.IOUNITS'
3439       include 'COMMON.GEO'
3440       include 'COMMON.VAR'
3441       include 'COMMON.LOCAL'
3442       include 'COMMON.CHAIN'
3443       include 'COMMON.DERIV'
3444       include 'COMMON.INTERACT'
3445       include 'COMMON.CONTACTS'
3446       include 'COMMON.TORSION'
3447       include 'COMMON.VECTORS'
3448       include 'COMMON.FFIELD'
3449       include 'COMMON.CONTROL'
3450       include 'COMMON.SHIELD'
3451       dimension ggg(3)
3452       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3453      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3454      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3455      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3456      &  auxgmat2(2,2),auxgmatt2(2,2)
3457       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3458      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3459       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3460      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3461      &    num_conti,j1,j2
3462       j=i+2
3463 c      write (iout,*) "eturn3",i,j,j1,j2
3464       a_temp(1,1)=a22
3465       a_temp(1,2)=a23
3466       a_temp(2,1)=a32
3467       a_temp(2,2)=a33
3468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3469 C
3470 C               Third-order contributions
3471 C
3472 C                 (i+2)o----(i+3)
3473 C                      | |
3474 C                      | |
3475 C                 (i+1)o----i
3476 C
3477 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3478 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3479         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3480 c auxalary matices for theta gradient
3481 c auxalary matrix for i+1 and constant i+2
3482         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3483 c auxalary matrix for i+2 and constant i+1
3484         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3485         call transpose2(auxmat(1,1),auxmat1(1,1))
3486         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3487         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3488         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3489         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3490         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3491         if (shield_mode.eq.0) then
3492         fac_shield(i)=1.0
3493         fac_shield(j)=1.0
3494 C        else
3495 C        fac_shield(i)=0.4
3496 C        fac_shield(j)=0.6
3497         endif
3498         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3499      &  *fac_shield(i)*fac_shield(j)
3500         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3501      &  *fac_shield(i)*fac_shield(j)
3502         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3503      &    eello_t3
3504         if (calc_grad) then
3505 C#ifdef NEWCORR
3506 C Derivatives in theta
3507         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3508      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3509      &   *fac_shield(i)*fac_shield(j)
3510         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3511      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3512      &   *fac_shield(i)*fac_shield(j)
3513 C#endif
3514
3515 C Derivatives in shield mode
3516           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3517      &  (shield_mode.gt.0)) then
3518 C          print *,i,j
3519
3520           do ilist=1,ishield_list(i)
3521            iresshield=shield_list(ilist,i)
3522            do k=1,3
3523            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3524 C     &      *2.0
3525            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3526      &              rlocshield
3527      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3528             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3529      &      +rlocshield
3530            enddo
3531           enddo
3532           do ilist=1,ishield_list(j)
3533            iresshield=shield_list(ilist,j)
3534            do k=1,3
3535            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3536 C     &     *2.0
3537            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3538      &              rlocshield
3539      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3540            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3541      &             +rlocshield
3542
3543            enddo
3544           enddo
3545
3546           do k=1,3
3547             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3548      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3549             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3550      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3551             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3552      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3553             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3554      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3555            enddo
3556            endif
3557
3558 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3559 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3560 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3561 cd     &    ' eello_turn3_num',4*eello_turn3_num
3562 C Derivatives in gamma(i)
3563         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3564         call transpose2(auxmat2(1,1),auxmat3(1,1))
3565         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3566         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3567      &   *fac_shield(i)*fac_shield(j)
3568 C Derivatives in gamma(i+1)
3569         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3570         call transpose2(auxmat2(1,1),auxmat3(1,1))
3571         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3572         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3573      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3574      &   *fac_shield(i)*fac_shield(j)
3575 C Cartesian derivatives
3576         do l=1,3
3577 c            ghalf1=0.5d0*agg(l,1)
3578 c            ghalf2=0.5d0*agg(l,2)
3579 c            ghalf3=0.5d0*agg(l,3)
3580 c            ghalf4=0.5d0*agg(l,4)
3581           a_temp(1,1)=aggi(l,1)!+ghalf1
3582           a_temp(1,2)=aggi(l,2)!+ghalf2
3583           a_temp(2,1)=aggi(l,3)!+ghalf3
3584           a_temp(2,2)=aggi(l,4)!+ghalf4
3585           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3586           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3587      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3588      &   *fac_shield(i)*fac_shield(j)
3589
3590           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3591           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3592           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3593           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3594           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3595           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3596      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3597      &   *fac_shield(i)*fac_shield(j)
3598           a_temp(1,1)=aggj(l,1)!+ghalf1
3599           a_temp(1,2)=aggj(l,2)!+ghalf2
3600           a_temp(2,1)=aggj(l,3)!+ghalf3
3601           a_temp(2,2)=aggj(l,4)!+ghalf4
3602           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3603           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3604      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3605      &   *fac_shield(i)*fac_shield(j)
3606           a_temp(1,1)=aggj1(l,1)
3607           a_temp(1,2)=aggj1(l,2)
3608           a_temp(2,1)=aggj1(l,3)
3609           a_temp(2,2)=aggj1(l,4)
3610           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3611           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3612      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3613      &   *fac_shield(i)*fac_shield(j)
3614         enddo
3615
3616         endif ! calc_grad
3617
3618       return
3619       end
3620 C-------------------------------------------------------------------------------
3621       subroutine eturn4(i,eello_turn4)
3622 C Third- and fourth-order contributions from turns
3623       implicit real*8 (a-h,o-z)
3624       include 'DIMENSIONS'
3625       include 'COMMON.IOUNITS'
3626       include 'COMMON.GEO'
3627       include 'COMMON.VAR'
3628       include 'COMMON.LOCAL'
3629       include 'COMMON.CHAIN'
3630       include 'COMMON.DERIV'
3631       include 'COMMON.INTERACT'
3632       include 'COMMON.CONTACTS'
3633       include 'COMMON.TORSION'
3634       include 'COMMON.VECTORS'
3635       include 'COMMON.FFIELD'
3636       include 'COMMON.CONTROL'
3637       include 'COMMON.SHIELD'
3638       dimension ggg(3)
3639       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3640      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3641      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3642      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3643      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3644      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3645      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3646       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3647      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3648       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3649      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3650      &    num_conti,j1,j2
3651       j=i+3
3652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3653 C
3654 C               Fourth-order contributions
3655 C
3656 C                 (i+3)o----(i+4)
3657 C                     /  |
3658 C               (i+2)o   |
3659 C                     \  |
3660 C                 (i+1)o----i
3661 C
3662 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3663 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3664 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3665 c        write(iout,*)"WCHODZE W PROGRAM"
3666         a_temp(1,1)=a22
3667         a_temp(1,2)=a23
3668         a_temp(2,1)=a32
3669         a_temp(2,2)=a33
3670         iti1=itype2loc(itype(i+1))
3671         iti2=itype2loc(itype(i+2))
3672         iti3=itype2loc(itype(i+3))
3673 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3674         call transpose2(EUg(1,1,i+1),e1t(1,1))
3675         call transpose2(Eug(1,1,i+2),e2t(1,1))
3676         call transpose2(Eug(1,1,i+3),e3t(1,1))
3677 C Ematrix derivative in theta
3678         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3679         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3680         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3681         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3682 c       eta1 in derivative theta
3683         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3684         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3685 c       auxgvec is derivative of Ub2 so i+3 theta
3686         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3687 c       auxalary matrix of E i+1
3688         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3689 c        s1=0.0
3690 c        gs1=0.0
3691         s1=scalar2(b1(1,i+2),auxvec(1))
3692 c derivative of theta i+2 with constant i+3
3693         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3694 c derivative of theta i+2 with constant i+2
3695         gs32=scalar2(b1(1,i+2),auxgvec(1))
3696 c derivative of E matix in theta of i+1
3697         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3698
3699         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3700 c       ea31 in derivative theta
3701         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3702         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3703 c auxilary matrix auxgvec of Ub2 with constant E matirx
3704         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3705 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3706         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3707
3708 c        s2=0.0
3709 c        gs2=0.0
3710         s2=scalar2(b1(1,i+1),auxvec(1))
3711 c derivative of theta i+1 with constant i+3
3712         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3713 c derivative of theta i+2 with constant i+1
3714         gs21=scalar2(b1(1,i+1),auxgvec(1))
3715 c derivative of theta i+3 with constant i+1
3716         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3717 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3718 c     &  gtb1(1,i+1)
3719         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3720 c two derivatives over diffetent matrices
3721 c gtae3e2 is derivative over i+3
3722         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3723 c ae3gte2 is derivative over i+2
3724         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3725         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3726 c three possible derivative over theta E matices
3727 c i+1
3728         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3729 c i+2
3730         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3731 c i+3
3732         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3733         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3734
3735         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3736         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3737         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3738         if (shield_mode.eq.0) then
3739         fac_shield(i)=1.0
3740         fac_shield(j)=1.0
3741 C        else
3742 C        fac_shield(i)=0.6
3743 C        fac_shield(j)=0.4
3744         endif
3745         eello_turn4=eello_turn4-(s1+s2+s3)
3746      &  *fac_shield(i)*fac_shield(j)
3747         eello_t4=-(s1+s2+s3)
3748      &  *fac_shield(i)*fac_shield(j)
3749 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3750         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3751      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3752 C Now derivative over shield:
3753           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3754      &  (shield_mode.gt.0)) then
3755 C          print *,i,j
3756
3757           do ilist=1,ishield_list(i)
3758            iresshield=shield_list(ilist,i)
3759            do k=1,3
3760            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3761 C     &      *2.0
3762            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3763      &              rlocshield
3764      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3765             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3766      &      +rlocshield
3767            enddo
3768           enddo
3769           do ilist=1,ishield_list(j)
3770            iresshield=shield_list(ilist,j)
3771            do k=1,3
3772            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3773 C     &     *2.0
3774            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3775      &              rlocshield
3776      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3777            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3778      &             +rlocshield
3779
3780            enddo
3781           enddo
3782
3783           do k=1,3
3784             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3785      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3786             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3787      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3788             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3789      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3790             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3791      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3792            enddo
3793            endif
3794 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3795 cd     &    ' eello_turn4_num',8*eello_turn4_num
3796 #ifdef NEWCORR
3797         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3798      &                  -(gs13+gsE13+gsEE1)*wturn4
3799      &  *fac_shield(i)*fac_shield(j)
3800         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3801      &                    -(gs23+gs21+gsEE2)*wturn4
3802      &  *fac_shield(i)*fac_shield(j)
3803
3804         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3805      &                    -(gs32+gsE31+gsEE3)*wturn4
3806      &  *fac_shield(i)*fac_shield(j)
3807
3808 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3809 c     &   gs2
3810 #endif
3811         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3812      &      'eturn4',i,j,-(s1+s2+s3)
3813 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3814 c     &    ' eello_turn4_num',8*eello_turn4_num
3815 C Derivatives in gamma(i)
3816         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3817         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3818         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3819         s1=scalar2(b1(1,i+2),auxvec(1))
3820         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3821         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3822         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3823      &  *fac_shield(i)*fac_shield(j)
3824 C Derivatives in gamma(i+1)
3825         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3826         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3827         s2=scalar2(b1(1,i+1),auxvec(1))
3828         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3829         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3830         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3831         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3832      &  *fac_shield(i)*fac_shield(j)
3833 C Derivatives in gamma(i+2)
3834         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3835         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3836         s1=scalar2(b1(1,i+2),auxvec(1))
3837         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3838         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3839         s2=scalar2(b1(1,i+1),auxvec(1))
3840         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3841         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3842         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3843         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3844      &  *fac_shield(i)*fac_shield(j)
3845         if (calc_grad) then
3846 C Cartesian derivatives
3847 C Derivatives of this turn contributions in DC(i+2)
3848         if (j.lt.nres-1) then
3849           do l=1,3
3850             a_temp(1,1)=agg(l,1)
3851             a_temp(1,2)=agg(l,2)
3852             a_temp(2,1)=agg(l,3)
3853             a_temp(2,2)=agg(l,4)
3854             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3855             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3856             s1=scalar2(b1(1,i+2),auxvec(1))
3857             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3858             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3859             s2=scalar2(b1(1,i+1),auxvec(1))
3860             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3861             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3862             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3863             ggg(l)=-(s1+s2+s3)
3864             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3865      &  *fac_shield(i)*fac_shield(j)
3866           enddo
3867         endif
3868 C Remaining derivatives of this turn contribution
3869         do l=1,3
3870           a_temp(1,1)=aggi(l,1)
3871           a_temp(1,2)=aggi(l,2)
3872           a_temp(2,1)=aggi(l,3)
3873           a_temp(2,2)=aggi(l,4)
3874           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3875           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3876           s1=scalar2(b1(1,i+2),auxvec(1))
3877           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3878           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3879           s2=scalar2(b1(1,i+1),auxvec(1))
3880           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3881           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3882           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3883           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3884      &  *fac_shield(i)*fac_shield(j)
3885           a_temp(1,1)=aggi1(l,1)
3886           a_temp(1,2)=aggi1(l,2)
3887           a_temp(2,1)=aggi1(l,3)
3888           a_temp(2,2)=aggi1(l,4)
3889           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3890           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3891           s1=scalar2(b1(1,i+2),auxvec(1))
3892           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3893           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3894           s2=scalar2(b1(1,i+1),auxvec(1))
3895           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3896           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3897           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3898           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3899      &  *fac_shield(i)*fac_shield(j)
3900           a_temp(1,1)=aggj(l,1)
3901           a_temp(1,2)=aggj(l,2)
3902           a_temp(2,1)=aggj(l,3)
3903           a_temp(2,2)=aggj(l,4)
3904           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3905           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3906           s1=scalar2(b1(1,i+2),auxvec(1))
3907           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3908           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3909           s2=scalar2(b1(1,i+1),auxvec(1))
3910           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3911           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3912           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3913           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3914      &  *fac_shield(i)*fac_shield(j)
3915           a_temp(1,1)=aggj1(l,1)
3916           a_temp(1,2)=aggj1(l,2)
3917           a_temp(2,1)=aggj1(l,3)
3918           a_temp(2,2)=aggj1(l,4)
3919           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3920           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3921           s1=scalar2(b1(1,i+2),auxvec(1))
3922           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3923           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3924           s2=scalar2(b1(1,i+1),auxvec(1))
3925           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3926           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3927           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3928 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3929           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3930      &  *fac_shield(i)*fac_shield(j)
3931         enddo
3932
3933         endif ! calc_grad
3934
3935       return
3936       end
3937 C-----------------------------------------------------------------------------
3938       subroutine vecpr(u,v,w)
3939       implicit real*8(a-h,o-z)
3940       dimension u(3),v(3),w(3)
3941       w(1)=u(2)*v(3)-u(3)*v(2)
3942       w(2)=-u(1)*v(3)+u(3)*v(1)
3943       w(3)=u(1)*v(2)-u(2)*v(1)
3944       return
3945       end
3946 C-----------------------------------------------------------------------------
3947       subroutine unormderiv(u,ugrad,unorm,ungrad)
3948 C This subroutine computes the derivatives of a normalized vector u, given
3949 C the derivatives computed without normalization conditions, ugrad. Returns
3950 C ungrad.
3951       implicit none
3952       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3953       double precision vec(3)
3954       double precision scalar
3955       integer i,j
3956 c      write (2,*) 'ugrad',ugrad
3957 c      write (2,*) 'u',u
3958       do i=1,3
3959         vec(i)=scalar(ugrad(1,i),u(1))
3960       enddo
3961 c      write (2,*) 'vec',vec
3962       do i=1,3
3963         do j=1,3
3964           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3965         enddo
3966       enddo
3967 c      write (2,*) 'ungrad',ungrad
3968       return
3969       end
3970 C-----------------------------------------------------------------------------
3971       subroutine escp(evdw2,evdw2_14)
3972 C
3973 C This subroutine calculates the excluded-volume interaction energy between
3974 C peptide-group centers and side chains and its gradient in virtual-bond and
3975 C side-chain vectors.
3976 C
3977       implicit real*8 (a-h,o-z)
3978       include 'DIMENSIONS'
3979       include 'COMMON.GEO'
3980       include 'COMMON.VAR'
3981       include 'COMMON.LOCAL'
3982       include 'COMMON.CHAIN'
3983       include 'COMMON.DERIV'
3984       include 'COMMON.INTERACT'
3985       include 'COMMON.FFIELD'
3986       include 'COMMON.IOUNITS'
3987       dimension ggg(3)
3988       evdw2=0.0D0
3989       evdw2_14=0.0d0
3990 cd    print '(a)','Enter ESCP'
3991 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3992 c     &  ' scal14',scal14
3993       do i=iatscp_s,iatscp_e
3994         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3995         iteli=itel(i)
3996 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3997 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3998         if (iteli.eq.0) goto 1225
3999         xi=0.5D0*(c(1,i)+c(1,i+1))
4000         yi=0.5D0*(c(2,i)+c(2,i+1))
4001         zi=0.5D0*(c(3,i)+c(3,i+1))
4002 C Returning the ith atom to box
4003           xi=mod(xi,boxxsize)
4004           if (xi.lt.0) xi=xi+boxxsize
4005           yi=mod(yi,boxysize)
4006           if (yi.lt.0) yi=yi+boxysize
4007           zi=mod(zi,boxzsize)
4008           if (zi.lt.0) zi=zi+boxzsize
4009         do iint=1,nscp_gr(i)
4010
4011         do j=iscpstart(i,iint),iscpend(i,iint)
4012           itypj=iabs(itype(j))
4013           if (itypj.eq.ntyp1) cycle
4014 C Uncomment following three lines for SC-p interactions
4015 c         xj=c(1,nres+j)-xi
4016 c         yj=c(2,nres+j)-yi
4017 c         zj=c(3,nres+j)-zi
4018 C Uncomment following three lines for Ca-p interactions
4019           xj=c(1,j)
4020           yj=c(2,j)
4021           zj=c(3,j)
4022 C returning the jth atom to box
4023           xj=mod(xj,boxxsize)
4024           if (xj.lt.0) xj=xj+boxxsize
4025           yj=mod(yj,boxysize)
4026           if (yj.lt.0) yj=yj+boxysize
4027           zj=mod(zj,boxzsize)
4028           if (zj.lt.0) zj=zj+boxzsize
4029       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4030       xj_safe=xj
4031       yj_safe=yj
4032       zj_safe=zj
4033       subchap=0
4034 C Finding the closest jth atom
4035       do xshift=-1,1
4036       do yshift=-1,1
4037       do zshift=-1,1
4038           xj=xj_safe+xshift*boxxsize
4039           yj=yj_safe+yshift*boxysize
4040           zj=zj_safe+zshift*boxzsize
4041           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4042           if(dist_temp.lt.dist_init) then
4043             dist_init=dist_temp
4044             xj_temp=xj
4045             yj_temp=yj
4046             zj_temp=zj
4047             subchap=1
4048           endif
4049        enddo
4050        enddo
4051        enddo
4052        if (subchap.eq.1) then
4053           xj=xj_temp-xi
4054           yj=yj_temp-yi
4055           zj=zj_temp-zi
4056        else
4057           xj=xj_safe-xi
4058           yj=yj_safe-yi
4059           zj=zj_safe-zi
4060        endif
4061           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4062 C sss is scaling function for smoothing the cutoff gradient otherwise
4063 C the gradient would not be continuouse
4064           sss=sscale(1.0d0/(dsqrt(rrij)))
4065           if (sss.le.0.0d0) cycle
4066           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4067           fac=rrij**expon2
4068           e1=fac*fac*aad(itypj,iteli)
4069           e2=fac*bad(itypj,iteli)
4070           if (iabs(j-i) .le. 2) then
4071             e1=scal14*e1
4072             e2=scal14*e2
4073             evdw2_14=evdw2_14+(e1+e2)*sss
4074           endif
4075           evdwij=e1+e2
4076 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4077 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4078 c     &       bad(itypj,iteli)
4079           evdw2=evdw2+evdwij*sss
4080           if (calc_grad) then
4081 C
4082 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4083 C
4084           fac=-(evdwij+e1)*rrij*sss
4085           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4086           ggg(1)=xj*fac
4087           ggg(2)=yj*fac
4088           ggg(3)=zj*fac
4089           if (j.lt.i) then
4090 cd          write (iout,*) 'j<i'
4091 C Uncomment following three lines for SC-p interactions
4092 c           do k=1,3
4093 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4094 c           enddo
4095           else
4096 cd          write (iout,*) 'j>i'
4097             do k=1,3
4098               ggg(k)=-ggg(k)
4099 C Uncomment following line for SC-p interactions
4100 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4101             enddo
4102           endif
4103           do k=1,3
4104             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4105           enddo
4106           kstart=min0(i+1,j)
4107           kend=max0(i-1,j-1)
4108 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4109 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4110           do k=kstart,kend
4111             do l=1,3
4112               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4113             enddo
4114           enddo
4115           endif ! calc_grad
4116         enddo
4117         enddo ! iint
4118  1225   continue
4119       enddo ! i
4120       do i=1,nct
4121         do j=1,3
4122           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4123           gradx_scp(j,i)=expon*gradx_scp(j,i)
4124         enddo
4125       enddo
4126 C******************************************************************************
4127 C
4128 C                              N O T E !!!
4129 C
4130 C To save time the factor EXPON has been extracted from ALL components
4131 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4132 C use!
4133 C
4134 C******************************************************************************
4135       return
4136       end
4137 C--------------------------------------------------------------------------
4138       subroutine edis(ehpb)
4139 C
4140 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4141 C
4142       implicit real*8 (a-h,o-z)
4143       include 'DIMENSIONS'
4144       include 'COMMON.SBRIDGE'
4145       include 'COMMON.CHAIN'
4146       include 'COMMON.DERIV'
4147       include 'COMMON.VAR'
4148       include 'COMMON.INTERACT'
4149       include 'COMMON.CONTROL'
4150       include 'COMMON.IOUNITS'
4151       dimension ggg(3)
4152       ehpb=0.0D0
4153 c      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4154 c      write(iout,*)'link_start=',link_start,' link_end=',link_end
4155 C      write(iout,*) link_end, "link_end"
4156       if (link_end.eq.0) return
4157       do i=link_start,link_end
4158 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4159 C CA-CA distance used in regularization of structure.
4160         ii=ihpb(i)
4161         jj=jhpb(i)
4162 C iii and jjj point to the residues for which the distance is assigned.
4163         if (ii.gt.nres) then
4164           iii=ii-nres
4165           jjj=jj-nres
4166         else
4167           iii=ii
4168           jjj=jj
4169         endif
4170 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4171 C    distance and angle dependent SS bond potential.
4172 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4173 C     & iabs(itype(jjj)).eq.1) then
4174 C       write(iout,*) constr_dist,"const"
4175        if (.not.dyn_ss .and. i.le.nss) then
4176          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4177      & iabs(itype(jjj)).eq.1) then
4178           call ssbond_ene(iii,jjj,eij)
4179           ehpb=ehpb+2*eij
4180            endif !ii.gt.neres
4181         else if (ii.gt.nres .and. jj.gt.nres) then
4182 c Restraints from contact prediction
4183           dd=dist(ii,jj)
4184           if (constr_dist.eq.11) then
4185 C            ehpb=ehpb+fordepth(i)**4.0d0
4186 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4187             ehpb=ehpb+fordepth(i)!**4.0d0
4188      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4189             fac=fordepth(i)!**4.0d0
4190      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4191 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4192 C     &    ehpb,fordepth(i),dd
4193 C            write(iout,*) ehpb,"atu?"
4194 C            ehpb,"tu?"
4195 C            fac=fordepth(i)**4.0d0
4196 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4197            else
4198           if (dhpb1(i).gt.0.0d0) then
4199             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4200             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4201 c            write (iout,*) "beta nmr",
4202 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4203           else
4204             dd=dist(ii,jj)
4205             rdis=dd-dhpb(i)
4206 C Get the force constant corresponding to this distance.
4207             waga=forcon(i)
4208 C Calculate the contribution to energy.
4209             ehpb=ehpb+waga*rdis*rdis
4210 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4211 C
4212 C Evaluate gradient.
4213 C
4214             fac=waga*rdis/dd
4215           endif !end dhpb1(i).gt.0
4216           endif !end const_dist=11
4217           do j=1,3
4218             ggg(j)=fac*(c(j,jj)-c(j,ii))
4219           enddo
4220           do j=1,3
4221             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4222             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4223           enddo
4224           do k=1,3
4225             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4226             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4227           enddo
4228         else !ii.gt.nres
4229 C          write(iout,*) "before"
4230           dd=dist(ii,jj)
4231 C          write(iout,*) "after",dd
4232           if (constr_dist.eq.11) then
4233             ehpb=ehpb+fordepth(i)!**4.0d0
4234      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4235             fac=fordepth(i)!**4.0d0
4236      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4237 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
4238 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
4239 C            print *,ehpb,"tu?"
4240 C            write(iout,*) ehpb,"btu?",
4241 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
4242 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4243 C     &    ehpb,fordepth(i),dd
4244            else
4245           if (dhpb1(i).gt.0.0d0) then
4246             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4247             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4248 c            write (iout,*) "alph nmr",
4249 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4250           else
4251             rdis=dd-dhpb(i)
4252 C Get the force constant corresponding to this distance.
4253             waga=forcon(i)
4254 C Calculate the contribution to energy.
4255             ehpb=ehpb+waga*rdis*rdis
4256 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4257 C
4258 C Evaluate gradient.
4259 C
4260             fac=waga*rdis/dd
4261           endif
4262           endif
4263
4264         do j=1,3
4265           ggg(j)=fac*(c(j,jj)-c(j,ii))
4266         enddo
4267 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4268 C If this is a SC-SC distance, we need to calculate the contributions to the
4269 C Cartesian gradient in the SC vectors (ghpbx).
4270         if (iii.lt.ii) then
4271           do j=1,3
4272             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4273             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4274           enddo
4275         endif
4276         do j=iii,jjj-1
4277           do k=1,3
4278             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4279           enddo
4280         enddo
4281         endif
4282       enddo
4283       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4284       return
4285       end
4286 C--------------------------------------------------------------------------
4287       subroutine ssbond_ene(i,j,eij)
4288 C
4289 C Calculate the distance and angle dependent SS-bond potential energy
4290 C using a free-energy function derived based on RHF/6-31G** ab initio
4291 C calculations of diethyl disulfide.
4292 C
4293 C A. Liwo and U. Kozlowska, 11/24/03
4294 C
4295       implicit real*8 (a-h,o-z)
4296       include 'DIMENSIONS'
4297       include 'COMMON.SBRIDGE'
4298       include 'COMMON.CHAIN'
4299       include 'COMMON.DERIV'
4300       include 'COMMON.LOCAL'
4301       include 'COMMON.INTERACT'
4302       include 'COMMON.VAR'
4303       include 'COMMON.IOUNITS'
4304       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4305       itypi=iabs(itype(i))
4306       xi=c(1,nres+i)
4307       yi=c(2,nres+i)
4308       zi=c(3,nres+i)
4309       dxi=dc_norm(1,nres+i)
4310       dyi=dc_norm(2,nres+i)
4311       dzi=dc_norm(3,nres+i)
4312       dsci_inv=dsc_inv(itypi)
4313       itypj=iabs(itype(j))
4314       dscj_inv=dsc_inv(itypj)
4315       xj=c(1,nres+j)-xi
4316       yj=c(2,nres+j)-yi
4317       zj=c(3,nres+j)-zi
4318       dxj=dc_norm(1,nres+j)
4319       dyj=dc_norm(2,nres+j)
4320       dzj=dc_norm(3,nres+j)
4321       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4322       rij=dsqrt(rrij)
4323       erij(1)=xj*rij
4324       erij(2)=yj*rij
4325       erij(3)=zj*rij
4326       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4327       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4328       om12=dxi*dxj+dyi*dyj+dzi*dzj
4329       do k=1,3
4330         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4331         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4332       enddo
4333       rij=1.0d0/rij
4334       deltad=rij-d0cm
4335       deltat1=1.0d0-om1
4336       deltat2=1.0d0+om2
4337       deltat12=om2-om1+2.0d0
4338       cosphi=om12-om1*om2
4339       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4340      &  +akct*deltad*deltat12
4341      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4342 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4343 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4344 c     &  " deltat12",deltat12," eij",eij
4345       ed=2*akcm*deltad+akct*deltat12
4346       pom1=akct*deltad
4347       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4348       eom1=-2*akth*deltat1-pom1-om2*pom2
4349       eom2= 2*akth*deltat2+pom1-om1*pom2
4350       eom12=pom2
4351       do k=1,3
4352         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4353       enddo
4354       do k=1,3
4355         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4356      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4357         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4358      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4359       enddo
4360 C
4361 C Calculate the components of the gradient in DC and X
4362 C
4363       do k=i,j-1
4364         do l=1,3
4365           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4366         enddo
4367       enddo
4368       return
4369       end
4370 C--------------------------------------------------------------------------
4371       subroutine ebond(estr)
4372 c
4373 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4374 c
4375       implicit real*8 (a-h,o-z)
4376       include 'DIMENSIONS'
4377       include 'COMMON.LOCAL'
4378       include 'COMMON.GEO'
4379       include 'COMMON.INTERACT'
4380       include 'COMMON.DERIV'
4381       include 'COMMON.VAR'
4382       include 'COMMON.CHAIN'
4383       include 'COMMON.IOUNITS'
4384       include 'COMMON.NAMES'
4385       include 'COMMON.FFIELD'
4386       include 'COMMON.CONTROL'
4387       double precision u(3),ud(3)
4388       estr=0.0d0
4389       estr1=0.0d0
4390 c      write (iout,*) "distchainmax",distchainmax
4391       do i=nnt+1,nct
4392         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4393 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4394 C          do j=1,3
4395 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4396 C     &      *dc(j,i-1)/vbld(i)
4397 C          enddo
4398 C          if (energy_dec) write(iout,*)
4399 C     &       "estr1",i,vbld(i),distchainmax,
4400 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4401 C        else
4402          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4403         diff = vbld(i)-vbldpDUM
4404 C         write(iout,*) i,diff
4405          else
4406           diff = vbld(i)-vbldp0
4407 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4408          endif
4409           estr=estr+diff*diff
4410           do j=1,3
4411             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4412           enddo
4413 C        endif
4414 C        write (iout,'(a7,i5,4f7.3)')
4415 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4416       enddo
4417       estr=0.5d0*AKP*estr+estr1
4418 c
4419 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4420 c
4421       do i=nnt,nct
4422         iti=iabs(itype(i))
4423         if (iti.ne.10 .and. iti.ne.ntyp1) then
4424           nbi=nbondterm(iti)
4425           if (nbi.eq.1) then
4426             diff=vbld(i+nres)-vbldsc0(1,iti)
4427 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4428 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4429             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4430             do j=1,3
4431               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4432             enddo
4433           else
4434             do j=1,nbi
4435               diff=vbld(i+nres)-vbldsc0(j,iti)
4436               ud(j)=aksc(j,iti)*diff
4437               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4438             enddo
4439             uprod=u(1)
4440             do j=2,nbi
4441               uprod=uprod*u(j)
4442             enddo
4443             usum=0.0d0
4444             usumsqder=0.0d0
4445             do j=1,nbi
4446               uprod1=1.0d0
4447               uprod2=1.0d0
4448               do k=1,nbi
4449                 if (k.ne.j) then
4450                   uprod1=uprod1*u(k)
4451                   uprod2=uprod2*u(k)*u(k)
4452                 endif
4453               enddo
4454               usum=usum+uprod1
4455               usumsqder=usumsqder+ud(j)*uprod2
4456             enddo
4457 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4458 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4459             estr=estr+uprod/usum
4460             do j=1,3
4461              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4462             enddo
4463           endif
4464         endif
4465       enddo
4466       return
4467       end
4468 #ifdef CRYST_THETA
4469 C--------------------------------------------------------------------------
4470       subroutine ebend(etheta,ethetacnstr)
4471 C
4472 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4473 C angles gamma and its derivatives in consecutive thetas and gammas.
4474 C
4475       implicit real*8 (a-h,o-z)
4476       include 'DIMENSIONS'
4477       include 'COMMON.LOCAL'
4478       include 'COMMON.GEO'
4479       include 'COMMON.INTERACT'
4480       include 'COMMON.DERIV'
4481       include 'COMMON.VAR'
4482       include 'COMMON.CHAIN'
4483       include 'COMMON.IOUNITS'
4484       include 'COMMON.NAMES'
4485       include 'COMMON.FFIELD'
4486       include 'COMMON.TORCNSTR'
4487       common /calcthet/ term1,term2,termm,diffak,ratak,
4488      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4489      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4490       double precision y(2),z(2)
4491       delta=0.02d0*pi
4492 c      time11=dexp(-2*time)
4493 c      time12=1.0d0
4494       etheta=0.0D0
4495 c      write (iout,*) "nres",nres
4496 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4497 c      write (iout,*) ithet_start,ithet_end
4498       do i=ithet_start,ithet_end
4499 C        if (itype(i-1).eq.ntyp1) cycle
4500         if (i.le.2) cycle
4501         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4502      &  .or.itype(i).eq.ntyp1) cycle
4503 C Zero the energy function and its derivative at 0 or pi.
4504         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4505         it=itype(i-1)
4506         ichir1=isign(1,itype(i-2))
4507         ichir2=isign(1,itype(i))
4508          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4509          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4510          if (itype(i-1).eq.10) then
4511           itype1=isign(10,itype(i-2))
4512           ichir11=isign(1,itype(i-2))
4513           ichir12=isign(1,itype(i-2))
4514           itype2=isign(10,itype(i))
4515           ichir21=isign(1,itype(i))
4516           ichir22=isign(1,itype(i))
4517          endif
4518          if (i.eq.3) then
4519           y(1)=0.0D0
4520           y(2)=0.0D0
4521           else
4522
4523         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4524 #ifdef OSF
4525           phii=phi(i)
4526 c          icrc=0
4527 c          call proc_proc(phii,icrc)
4528           if (icrc.eq.1) phii=150.0
4529 #else
4530           phii=phi(i)
4531 #endif
4532           y(1)=dcos(phii)
4533           y(2)=dsin(phii)
4534         else
4535           y(1)=0.0D0
4536           y(2)=0.0D0
4537         endif
4538         endif
4539         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4540 #ifdef OSF
4541           phii1=phi(i+1)
4542 c          icrc=0
4543 c          call proc_proc(phii1,icrc)
4544           if (icrc.eq.1) phii1=150.0
4545           phii1=pinorm(phii1)
4546           z(1)=cos(phii1)
4547 #else
4548           phii1=phi(i+1)
4549           z(1)=dcos(phii1)
4550 #endif
4551           z(2)=dsin(phii1)
4552         else
4553           z(1)=0.0D0
4554           z(2)=0.0D0
4555         endif
4556 C Calculate the "mean" value of theta from the part of the distribution
4557 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4558 C In following comments this theta will be referred to as t_c.
4559         thet_pred_mean=0.0d0
4560         do k=1,2
4561             athetk=athet(k,it,ichir1,ichir2)
4562             bthetk=bthet(k,it,ichir1,ichir2)
4563           if (it.eq.10) then
4564              athetk=athet(k,itype1,ichir11,ichir12)
4565              bthetk=bthet(k,itype2,ichir21,ichir22)
4566           endif
4567           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4568         enddo
4569 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4570         dthett=thet_pred_mean*ssd
4571         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4572 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4573 C Derivatives of the "mean" values in gamma1 and gamma2.
4574         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4575      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4576          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4577      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4578          if (it.eq.10) then
4579       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4580      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4581         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4582      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4583          endif
4584         if (theta(i).gt.pi-delta) then
4585           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4586      &         E_tc0)
4587           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4588           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4589           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4590      &        E_theta)
4591           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4592      &        E_tc)
4593         else if (theta(i).lt.delta) then
4594           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4595           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4596           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4597      &        E_theta)
4598           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4599           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4600      &        E_tc)
4601         else
4602           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4603      &        E_theta,E_tc)
4604         endif
4605         etheta=etheta+ethetai
4606 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4607 c     &      'ebend',i,ethetai,theta(i),itype(i)
4608 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4609 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4610         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4611         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4612         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4613 c 1215   continue
4614       enddo
4615       ethetacnstr=0.0d0
4616 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4617       do i=1,ntheta_constr
4618         itheta=itheta_constr(i)
4619         thetiii=theta(itheta)
4620         difi=pinorm(thetiii-theta_constr0(i))
4621         if (difi.gt.theta_drange(i)) then
4622           difi=difi-theta_drange(i)
4623           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4624           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4625      &    +for_thet_constr(i)*difi**3
4626         else if (difi.lt.-drange(i)) then
4627           difi=difi+drange(i)
4628           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4629           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4630      &    +for_thet_constr(i)*difi**3
4631         else
4632           difi=0.0
4633         endif
4634 C       if (energy_dec) then
4635 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4636 C     &    i,itheta,rad2deg*thetiii,
4637 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4638 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4639 C     &    gloc(itheta+nphi-2,icg)
4640 C        endif
4641       enddo
4642 C Ufff.... We've done all this!!!
4643       return
4644       end
4645 C---------------------------------------------------------------------------
4646       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4647      &     E_tc)
4648       implicit real*8 (a-h,o-z)
4649       include 'DIMENSIONS'
4650       include 'COMMON.LOCAL'
4651       include 'COMMON.IOUNITS'
4652       common /calcthet/ term1,term2,termm,diffak,ratak,
4653      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4654      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4655 C Calculate the contributions to both Gaussian lobes.
4656 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4657 C The "polynomial part" of the "standard deviation" of this part of
4658 C the distribution.
4659         sig=polthet(3,it)
4660         do j=2,0,-1
4661           sig=sig*thet_pred_mean+polthet(j,it)
4662         enddo
4663 C Derivative of the "interior part" of the "standard deviation of the"
4664 C gamma-dependent Gaussian lobe in t_c.
4665         sigtc=3*polthet(3,it)
4666         do j=2,1,-1
4667           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4668         enddo
4669         sigtc=sig*sigtc
4670 C Set the parameters of both Gaussian lobes of the distribution.
4671 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4672         fac=sig*sig+sigc0(it)
4673         sigcsq=fac+fac
4674         sigc=1.0D0/sigcsq
4675 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4676         sigsqtc=-4.0D0*sigcsq*sigtc
4677 c       print *,i,sig,sigtc,sigsqtc
4678 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4679         sigtc=-sigtc/(fac*fac)
4680 C Following variable is sigma(t_c)**(-2)
4681         sigcsq=sigcsq*sigcsq
4682         sig0i=sig0(it)
4683         sig0inv=1.0D0/sig0i**2
4684         delthec=thetai-thet_pred_mean
4685         delthe0=thetai-theta0i
4686         term1=-0.5D0*sigcsq*delthec*delthec
4687         term2=-0.5D0*sig0inv*delthe0*delthe0
4688 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4689 C NaNs in taking the logarithm. We extract the largest exponent which is added
4690 C to the energy (this being the log of the distribution) at the end of energy
4691 C term evaluation for this virtual-bond angle.
4692         if (term1.gt.term2) then
4693           termm=term1
4694           term2=dexp(term2-termm)
4695           term1=1.0d0
4696         else
4697           termm=term2
4698           term1=dexp(term1-termm)
4699           term2=1.0d0
4700         endif
4701 C The ratio between the gamma-independent and gamma-dependent lobes of
4702 C the distribution is a Gaussian function of thet_pred_mean too.
4703         diffak=gthet(2,it)-thet_pred_mean
4704         ratak=diffak/gthet(3,it)**2
4705         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4706 C Let's differentiate it in thet_pred_mean NOW.
4707         aktc=ak*ratak
4708 C Now put together the distribution terms to make complete distribution.
4709         termexp=term1+ak*term2
4710         termpre=sigc+ak*sig0i
4711 C Contribution of the bending energy from this theta is just the -log of
4712 C the sum of the contributions from the two lobes and the pre-exponential
4713 C factor. Simple enough, isn't it?
4714         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4715 C NOW the derivatives!!!
4716 C 6/6/97 Take into account the deformation.
4717         E_theta=(delthec*sigcsq*term1
4718      &       +ak*delthe0*sig0inv*term2)/termexp
4719         E_tc=((sigtc+aktc*sig0i)/termpre
4720      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4721      &       aktc*term2)/termexp)
4722       return
4723       end
4724 c-----------------------------------------------------------------------------
4725       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4726       implicit real*8 (a-h,o-z)
4727       include 'DIMENSIONS'
4728       include 'COMMON.LOCAL'
4729       include 'COMMON.IOUNITS'
4730       common /calcthet/ term1,term2,termm,diffak,ratak,
4731      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4732      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4733       delthec=thetai-thet_pred_mean
4734       delthe0=thetai-theta0i
4735 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4736       t3 = thetai-thet_pred_mean
4737       t6 = t3**2
4738       t9 = term1
4739       t12 = t3*sigcsq
4740       t14 = t12+t6*sigsqtc
4741       t16 = 1.0d0
4742       t21 = thetai-theta0i
4743       t23 = t21**2
4744       t26 = term2
4745       t27 = t21*t26
4746       t32 = termexp
4747       t40 = t32**2
4748       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4749      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4750      & *(-t12*t9-ak*sig0inv*t27)
4751       return
4752       end
4753 #else
4754 C--------------------------------------------------------------------------
4755       subroutine ebend(etheta)
4756 C
4757 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4758 C angles gamma and its derivatives in consecutive thetas and gammas.
4759 C ab initio-derived potentials from
4760 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4761 C
4762       implicit real*8 (a-h,o-z)
4763       include 'DIMENSIONS'
4764       include 'COMMON.LOCAL'
4765       include 'COMMON.GEO'
4766       include 'COMMON.INTERACT'
4767       include 'COMMON.DERIV'
4768       include 'COMMON.VAR'
4769       include 'COMMON.CHAIN'
4770       include 'COMMON.IOUNITS'
4771       include 'COMMON.NAMES'
4772       include 'COMMON.FFIELD'
4773       include 'COMMON.CONTROL'
4774       include 'COMMON.TORCNSTR'
4775       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4776      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4777      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4778      & sinph1ph2(maxdouble,maxdouble)
4779       logical lprn /.false./, lprn1 /.false./
4780       etheta=0.0D0
4781 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4782       do i=ithet_start,ithet_end
4783 C         if (i.eq.2) cycle
4784 C        if (itype(i-1).eq.ntyp1) cycle
4785         if (i.le.2) cycle
4786         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4787      &  .or.itype(i).eq.ntyp1) cycle
4788         if (iabs(itype(i+1)).eq.20) iblock=2
4789         if (iabs(itype(i+1)).ne.20) iblock=1
4790         dethetai=0.0d0
4791         dephii=0.0d0
4792         dephii1=0.0d0
4793         theti2=0.5d0*theta(i)
4794         ityp2=ithetyp((itype(i-1)))
4795         do k=1,nntheterm
4796           coskt(k)=dcos(k*theti2)
4797           sinkt(k)=dsin(k*theti2)
4798         enddo
4799         if (i.eq.3) then
4800           phii=0.0d0
4801           ityp1=nthetyp+1
4802           do k=1,nsingle
4803             cosph1(k)=0.0d0
4804             sinph1(k)=0.0d0
4805           enddo
4806         else
4807         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4808 #ifdef OSF
4809           phii=phi(i)
4810           if (phii.ne.phii) phii=150.0
4811 #else
4812           phii=phi(i)
4813 #endif
4814           ityp1=ithetyp((itype(i-2)))
4815           do k=1,nsingle
4816             cosph1(k)=dcos(k*phii)
4817             sinph1(k)=dsin(k*phii)
4818           enddo
4819         else
4820           phii=0.0d0
4821 c          ityp1=nthetyp+1
4822           do k=1,nsingle
4823             ityp1=ithetyp((itype(i-2)))
4824             cosph1(k)=0.0d0
4825             sinph1(k)=0.0d0
4826           enddo
4827         endif
4828         endif
4829         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4830 #ifdef OSF
4831           phii1=phi(i+1)
4832           if (phii1.ne.phii1) phii1=150.0
4833           phii1=pinorm(phii1)
4834 #else
4835           phii1=phi(i+1)
4836 #endif
4837           ityp3=ithetyp((itype(i)))
4838           do k=1,nsingle
4839             cosph2(k)=dcos(k*phii1)
4840             sinph2(k)=dsin(k*phii1)
4841           enddo
4842         else
4843           phii1=0.0d0
4844 c          ityp3=nthetyp+1
4845           ityp3=ithetyp((itype(i)))
4846           do k=1,nsingle
4847             cosph2(k)=0.0d0
4848             sinph2(k)=0.0d0
4849           enddo
4850         endif
4851 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4852 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4853 c        call flush(iout)
4854         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4855         do k=1,ndouble
4856           do l=1,k-1
4857             ccl=cosph1(l)*cosph2(k-l)
4858             ssl=sinph1(l)*sinph2(k-l)
4859             scl=sinph1(l)*cosph2(k-l)
4860             csl=cosph1(l)*sinph2(k-l)
4861             cosph1ph2(l,k)=ccl-ssl
4862             cosph1ph2(k,l)=ccl+ssl
4863             sinph1ph2(l,k)=scl+csl
4864             sinph1ph2(k,l)=scl-csl
4865           enddo
4866         enddo
4867         if (lprn) then
4868         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4869      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4870         write (iout,*) "coskt and sinkt"
4871         do k=1,nntheterm
4872           write (iout,*) k,coskt(k),sinkt(k)
4873         enddo
4874         endif
4875         do k=1,ntheterm
4876           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4877           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4878      &      *coskt(k)
4879           if (lprn)
4880      &    write (iout,*) "k",k,"
4881      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4882      &     " ethetai",ethetai
4883         enddo
4884         if (lprn) then
4885         write (iout,*) "cosph and sinph"
4886         do k=1,nsingle
4887           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4888         enddo
4889         write (iout,*) "cosph1ph2 and sinph2ph2"
4890         do k=2,ndouble
4891           do l=1,k-1
4892             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4893      &         sinph1ph2(l,k),sinph1ph2(k,l)
4894           enddo
4895         enddo
4896         write(iout,*) "ethetai",ethetai
4897         endif
4898         do m=1,ntheterm2
4899           do k=1,nsingle
4900             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4901      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4902      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4903      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4904             ethetai=ethetai+sinkt(m)*aux
4905             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4906             dephii=dephii+k*sinkt(m)*(
4907      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4908      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4909             dephii1=dephii1+k*sinkt(m)*(
4910      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4911      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4912             if (lprn)
4913      &      write (iout,*) "m",m," k",k," bbthet",
4914      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4915      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4916      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4917      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4918           enddo
4919         enddo
4920         if (lprn)
4921      &  write(iout,*) "ethetai",ethetai
4922         do m=1,ntheterm3
4923           do k=2,ndouble
4924             do l=1,k-1
4925               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4926      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4927      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4928      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4929               ethetai=ethetai+sinkt(m)*aux
4930               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4931               dephii=dephii+l*sinkt(m)*(
4932      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4933      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4934      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4935      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4936               dephii1=dephii1+(k-l)*sinkt(m)*(
4937      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4938      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4939      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4940      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4941               if (lprn) then
4942               write (iout,*) "m",m," k",k," l",l," ffthet",
4943      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4944      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4945      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4946      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4947      &            " ethetai",ethetai
4948               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4949      &            cosph1ph2(k,l)*sinkt(m),
4950      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4951               endif
4952             enddo
4953           enddo
4954         enddo
4955 10      continue
4956         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4957      &   i,theta(i)*rad2deg,phii*rad2deg,
4958      &   phii1*rad2deg,ethetai
4959         etheta=etheta+ethetai
4960         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4961         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4962 c        gloc(nphi+i-2,icg)=wang*dethetai
4963         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4964       enddo
4965       return
4966       end
4967 #endif
4968 #ifdef CRYST_SC
4969 c-----------------------------------------------------------------------------
4970       subroutine esc(escloc)
4971 C Calculate the local energy of a side chain and its derivatives in the
4972 C corresponding virtual-bond valence angles THETA and the spherical angles
4973 C ALPHA and OMEGA.
4974       implicit real*8 (a-h,o-z)
4975       include 'DIMENSIONS'
4976       include 'COMMON.GEO'
4977       include 'COMMON.LOCAL'
4978       include 'COMMON.VAR'
4979       include 'COMMON.INTERACT'
4980       include 'COMMON.DERIV'
4981       include 'COMMON.CHAIN'
4982       include 'COMMON.IOUNITS'
4983       include 'COMMON.NAMES'
4984       include 'COMMON.FFIELD'
4985       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4986      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4987       common /sccalc/ time11,time12,time112,theti,it,nlobit
4988       delta=0.02d0*pi
4989       escloc=0.0D0
4990 C      write (iout,*) 'ESC'
4991       do i=loc_start,loc_end
4992         it=itype(i)
4993         if (it.eq.ntyp1) cycle
4994         if (it.eq.10) goto 1
4995         nlobit=nlob(iabs(it))
4996 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4997 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4998         theti=theta(i+1)-pipol
4999         x(1)=dtan(theti)
5000         x(2)=alph(i)
5001         x(3)=omeg(i)
5002 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5003
5004         if (x(2).gt.pi-delta) then
5005           xtemp(1)=x(1)
5006           xtemp(2)=pi-delta
5007           xtemp(3)=x(3)
5008           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5009           xtemp(2)=pi
5010           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5011           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5012      &        escloci,dersc(2))
5013           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5014      &        ddersc0(1),dersc(1))
5015           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5016      &        ddersc0(3),dersc(3))
5017           xtemp(2)=pi-delta
5018           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5019           xtemp(2)=pi
5020           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5021           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5022      &            dersc0(2),esclocbi,dersc02)
5023           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5024      &            dersc12,dersc01)
5025           call splinthet(x(2),0.5d0*delta,ss,ssd)
5026           dersc0(1)=dersc01
5027           dersc0(2)=dersc02
5028           dersc0(3)=0.0d0
5029           do k=1,3
5030             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5031           enddo
5032           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5033           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5034      &             esclocbi,ss,ssd
5035           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5036 c         escloci=esclocbi
5037 c         write (iout,*) escloci
5038         else if (x(2).lt.delta) then
5039           xtemp(1)=x(1)
5040           xtemp(2)=delta
5041           xtemp(3)=x(3)
5042           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5043           xtemp(2)=0.0d0
5044           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5045           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5046      &        escloci,dersc(2))
5047           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5048      &        ddersc0(1),dersc(1))
5049           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5050      &        ddersc0(3),dersc(3))
5051           xtemp(2)=delta
5052           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5053           xtemp(2)=0.0d0
5054           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5055           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5056      &            dersc0(2),esclocbi,dersc02)
5057           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5058      &            dersc12,dersc01)
5059           dersc0(1)=dersc01
5060           dersc0(2)=dersc02
5061           dersc0(3)=0.0d0
5062           call splinthet(x(2),0.5d0*delta,ss,ssd)
5063           do k=1,3
5064             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5065           enddo
5066           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5067 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5068 c     &             esclocbi,ss,ssd
5069           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5070 C         write (iout,*) 'i=',i, escloci
5071         else
5072           call enesc(x,escloci,dersc,ddummy,.false.)
5073         endif
5074
5075         escloc=escloc+escloci
5076 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5077             write (iout,'(a6,i5,0pf7.3)')
5078      &     'escloc',i,escloci
5079
5080         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5081      &   wscloc*dersc(1)
5082         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5083         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5084     1   continue
5085       enddo
5086       return
5087       end
5088 C---------------------------------------------------------------------------
5089       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5090       implicit real*8 (a-h,o-z)
5091       include 'DIMENSIONS'
5092       include 'COMMON.GEO'
5093       include 'COMMON.LOCAL'
5094       include 'COMMON.IOUNITS'
5095       common /sccalc/ time11,time12,time112,theti,it,nlobit
5096       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5097       double precision contr(maxlob,-1:1)
5098       logical mixed
5099 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5100         escloc_i=0.0D0
5101         do j=1,3
5102           dersc(j)=0.0D0
5103           if (mixed) ddersc(j)=0.0d0
5104         enddo
5105         x3=x(3)
5106
5107 C Because of periodicity of the dependence of the SC energy in omega we have
5108 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5109 C To avoid underflows, first compute & store the exponents.
5110
5111         do iii=-1,1
5112
5113           x(3)=x3+iii*dwapi
5114
5115           do j=1,nlobit
5116             do k=1,3
5117               z(k)=x(k)-censc(k,j,it)
5118             enddo
5119             do k=1,3
5120               Axk=0.0D0
5121               do l=1,3
5122                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5123               enddo
5124               Ax(k,j,iii)=Axk
5125             enddo
5126             expfac=0.0D0
5127             do k=1,3
5128               expfac=expfac+Ax(k,j,iii)*z(k)
5129             enddo
5130             contr(j,iii)=expfac
5131           enddo ! j
5132
5133         enddo ! iii
5134
5135         x(3)=x3
5136 C As in the case of ebend, we want to avoid underflows in exponentiation and
5137 C subsequent NaNs and INFs in energy calculation.
5138 C Find the largest exponent
5139         emin=contr(1,-1)
5140         do iii=-1,1
5141           do j=1,nlobit
5142             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5143           enddo
5144         enddo
5145         emin=0.5D0*emin
5146 cd      print *,'it=',it,' emin=',emin
5147
5148 C Compute the contribution to SC energy and derivatives
5149         do iii=-1,1
5150
5151           do j=1,nlobit
5152             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5153 cd          print *,'j=',j,' expfac=',expfac
5154             escloc_i=escloc_i+expfac
5155             do k=1,3
5156               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5157             enddo
5158             if (mixed) then
5159               do k=1,3,2
5160                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5161      &            +gaussc(k,2,j,it))*expfac
5162               enddo
5163             endif
5164           enddo
5165
5166         enddo ! iii
5167
5168         dersc(1)=dersc(1)/cos(theti)**2
5169         ddersc(1)=ddersc(1)/cos(theti)**2
5170         ddersc(3)=ddersc(3)
5171
5172         escloci=-(dlog(escloc_i)-emin)
5173         do j=1,3
5174           dersc(j)=dersc(j)/escloc_i
5175         enddo
5176         if (mixed) then
5177           do j=1,3,2
5178             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5179           enddo
5180         endif
5181       return
5182       end
5183 C------------------------------------------------------------------------------
5184       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5185       implicit real*8 (a-h,o-z)
5186       include 'DIMENSIONS'
5187       include 'COMMON.GEO'
5188       include 'COMMON.LOCAL'
5189       include 'COMMON.IOUNITS'
5190       common /sccalc/ time11,time12,time112,theti,it,nlobit
5191       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5192       double precision contr(maxlob)
5193       logical mixed
5194
5195       escloc_i=0.0D0
5196
5197       do j=1,3
5198         dersc(j)=0.0D0
5199       enddo
5200
5201       do j=1,nlobit
5202         do k=1,2
5203           z(k)=x(k)-censc(k,j,it)
5204         enddo
5205         z(3)=dwapi
5206         do k=1,3
5207           Axk=0.0D0
5208           do l=1,3
5209             Axk=Axk+gaussc(l,k,j,it)*z(l)
5210           enddo
5211           Ax(k,j)=Axk
5212         enddo
5213         expfac=0.0D0
5214         do k=1,3
5215           expfac=expfac+Ax(k,j)*z(k)
5216         enddo
5217         contr(j)=expfac
5218       enddo ! j
5219
5220 C As in the case of ebend, we want to avoid underflows in exponentiation and
5221 C subsequent NaNs and INFs in energy calculation.
5222 C Find the largest exponent
5223       emin=contr(1)
5224       do j=1,nlobit
5225         if (emin.gt.contr(j)) emin=contr(j)
5226       enddo
5227       emin=0.5D0*emin
5228
5229 C Compute the contribution to SC energy and derivatives
5230
5231       dersc12=0.0d0
5232       do j=1,nlobit
5233         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5234         escloc_i=escloc_i+expfac
5235         do k=1,2
5236           dersc(k)=dersc(k)+Ax(k,j)*expfac
5237         enddo
5238         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5239      &            +gaussc(1,2,j,it))*expfac
5240         dersc(3)=0.0d0
5241       enddo
5242
5243       dersc(1)=dersc(1)/cos(theti)**2
5244       dersc12=dersc12/cos(theti)**2
5245       escloci=-(dlog(escloc_i)-emin)
5246       do j=1,2
5247         dersc(j)=dersc(j)/escloc_i
5248       enddo
5249       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5250       return
5251       end
5252 #else
5253 c----------------------------------------------------------------------------------
5254       subroutine esc(escloc)
5255 C Calculate the local energy of a side chain and its derivatives in the
5256 C corresponding virtual-bond valence angles THETA and the spherical angles
5257 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5258 C added by Urszula Kozlowska. 07/11/2007
5259 C
5260       implicit real*8 (a-h,o-z)
5261       include 'DIMENSIONS'
5262       include 'COMMON.GEO'
5263       include 'COMMON.LOCAL'
5264       include 'COMMON.VAR'
5265       include 'COMMON.SCROT'
5266       include 'COMMON.INTERACT'
5267       include 'COMMON.DERIV'
5268       include 'COMMON.CHAIN'
5269       include 'COMMON.IOUNITS'
5270       include 'COMMON.NAMES'
5271       include 'COMMON.FFIELD'
5272       include 'COMMON.CONTROL'
5273       include 'COMMON.VECTORS'
5274       double precision x_prime(3),y_prime(3),z_prime(3)
5275      &    , sumene,dsc_i,dp2_i,x(65),
5276      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5277      &    de_dxx,de_dyy,de_dzz,de_dt
5278       double precision s1_t,s1_6_t,s2_t,s2_6_t
5279       double precision
5280      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5281      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5282      & dt_dCi(3),dt_dCi1(3)
5283       common /sccalc/ time11,time12,time112,theti,it,nlobit
5284       delta=0.02d0*pi
5285       escloc=0.0D0
5286       do i=loc_start,loc_end
5287         if (itype(i).eq.ntyp1) cycle
5288         costtab(i+1) =dcos(theta(i+1))
5289         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5290         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5291         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5292         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5293         cosfac=dsqrt(cosfac2)
5294         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5295         sinfac=dsqrt(sinfac2)
5296         it=iabs(itype(i))
5297         if (it.eq.10) goto 1
5298 c
5299 C  Compute the axes of tghe local cartesian coordinates system; store in
5300 c   x_prime, y_prime and z_prime
5301 c
5302         do j=1,3
5303           x_prime(j) = 0.00
5304           y_prime(j) = 0.00
5305           z_prime(j) = 0.00
5306         enddo
5307 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5308 C     &   dc_norm(3,i+nres)
5309         do j = 1,3
5310           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5311           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5312         enddo
5313         do j = 1,3
5314           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5315         enddo
5316 c       write (2,*) "i",i
5317 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5318 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5319 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5320 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5321 c      & " xy",scalar(x_prime(1),y_prime(1)),
5322 c      & " xz",scalar(x_prime(1),z_prime(1)),
5323 c      & " yy",scalar(y_prime(1),y_prime(1)),
5324 c      & " yz",scalar(y_prime(1),z_prime(1)),
5325 c      & " zz",scalar(z_prime(1),z_prime(1))
5326 c
5327 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5328 C to local coordinate system. Store in xx, yy, zz.
5329 c
5330         xx=0.0d0
5331         yy=0.0d0
5332         zz=0.0d0
5333         do j = 1,3
5334           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5335           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5336           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5337         enddo
5338
5339         xxtab(i)=xx
5340         yytab(i)=yy
5341         zztab(i)=zz
5342 C
5343 C Compute the energy of the ith side cbain
5344 C
5345 c        write (2,*) "xx",xx," yy",yy," zz",zz
5346         it=iabs(itype(i))
5347         do j = 1,65
5348           x(j) = sc_parmin(j,it)
5349         enddo
5350 #ifdef CHECK_COORD
5351 Cc diagnostics - remove later
5352         xx1 = dcos(alph(2))
5353         yy1 = dsin(alph(2))*dcos(omeg(2))
5354         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5355         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5356      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5357      &    xx1,yy1,zz1
5358 C,"  --- ", xx_w,yy_w,zz_w
5359 c end diagnostics
5360 #endif
5361         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5362      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5363      &   + x(10)*yy*zz
5364         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5365      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5366      & + x(20)*yy*zz
5367         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5368      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5369      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5370      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5371      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5372      &  +x(40)*xx*yy*zz
5373         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5374      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5375      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5376      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5377      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5378      &  +x(60)*xx*yy*zz
5379         dsc_i   = 0.743d0+x(61)
5380         dp2_i   = 1.9d0+x(62)
5381         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5382      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5383         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5384      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5385         s1=(1+x(63))/(0.1d0 + dscp1)
5386         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5387         s2=(1+x(65))/(0.1d0 + dscp2)
5388         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5389         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5390      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5391 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5392 c     &   sumene4,
5393 c     &   dscp1,dscp2,sumene
5394 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5395         escloc = escloc + sumene
5396 c        write (2,*) "escloc",escloc
5397 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5398 c     &  zz,xx,yy
5399         if (.not. calc_grad) goto 1
5400 #ifdef DEBUG
5401 C
5402 C This section to check the numerical derivatives of the energy of ith side
5403 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5404 C #define DEBUG in the code to turn it on.
5405 C
5406         write (2,*) "sumene               =",sumene
5407         aincr=1.0d-7
5408         xxsave=xx
5409         xx=xx+aincr
5410         write (2,*) xx,yy,zz
5411         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5412         de_dxx_num=(sumenep-sumene)/aincr
5413         xx=xxsave
5414         write (2,*) "xx+ sumene from enesc=",sumenep
5415         yysave=yy
5416         yy=yy+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dyy_num=(sumenep-sumene)/aincr
5420         yy=yysave
5421         write (2,*) "yy+ sumene from enesc=",sumenep
5422         zzsave=zz
5423         zz=zz+aincr
5424         write (2,*) xx,yy,zz
5425         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5426         de_dzz_num=(sumenep-sumene)/aincr
5427         zz=zzsave
5428         write (2,*) "zz+ sumene from enesc=",sumenep
5429         costsave=cost2tab(i+1)
5430         sintsave=sint2tab(i+1)
5431         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5432         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5433         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5434         de_dt_num=(sumenep-sumene)/aincr
5435         write (2,*) " t+ sumene from enesc=",sumenep
5436         cost2tab(i+1)=costsave
5437         sint2tab(i+1)=sintsave
5438 C End of diagnostics section.
5439 #endif
5440 C
5441 C Compute the gradient of esc
5442 C
5443         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5444         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5445         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5446         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5447         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5448         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5449         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5450         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5451         pom1=(sumene3*sint2tab(i+1)+sumene1)
5452      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5453         pom2=(sumene4*cost2tab(i+1)+sumene2)
5454      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5455         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5456         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5457      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5458      &  +x(40)*yy*zz
5459         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5460         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5461      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5462      &  +x(60)*yy*zz
5463         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5464      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5465      &        +(pom1+pom2)*pom_dx
5466 #ifdef DEBUG
5467         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5468 #endif
5469 C
5470         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5471         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5472      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5473      &  +x(40)*xx*zz
5474         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5475         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5476      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5477      &  +x(59)*zz**2 +x(60)*xx*zz
5478         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5479      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5480      &        +(pom1-pom2)*pom_dy
5481 #ifdef DEBUG
5482         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5483 #endif
5484 C
5485         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5486      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5487      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5488      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5489      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5490      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5491      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5492      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5493 #ifdef DEBUG
5494         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5495 #endif
5496 C
5497         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5498      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5499      &  +pom1*pom_dt1+pom2*pom_dt2
5500 #ifdef DEBUG
5501         write(2,*), "de_dt = ", de_dt,de_dt_num
5502 #endif
5503 c
5504 C
5505        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5506        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5507        cosfac2xx=cosfac2*xx
5508        sinfac2yy=sinfac2*yy
5509        do k = 1,3
5510          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5511      &      vbld_inv(i+1)
5512          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5513      &      vbld_inv(i)
5514          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5515          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5516 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5517 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5518 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5519 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5520          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5521          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5522          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5523          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5524          dZZ_Ci1(k)=0.0d0
5525          dZZ_Ci(k)=0.0d0
5526          do j=1,3
5527            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5528      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5529            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5530      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5531          enddo
5532
5533          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5534          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5535          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5536 c
5537          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5538          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5539        enddo
5540
5541        do k=1,3
5542          dXX_Ctab(k,i)=dXX_Ci(k)
5543          dXX_C1tab(k,i)=dXX_Ci1(k)
5544          dYY_Ctab(k,i)=dYY_Ci(k)
5545          dYY_C1tab(k,i)=dYY_Ci1(k)
5546          dZZ_Ctab(k,i)=dZZ_Ci(k)
5547          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5548          dXX_XYZtab(k,i)=dXX_XYZ(k)
5549          dYY_XYZtab(k,i)=dYY_XYZ(k)
5550          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5551        enddo
5552
5553        do k = 1,3
5554 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5555 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5556 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5557 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5558 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5559 c     &    dt_dci(k)
5560 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5561 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5562          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5563      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5564          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5565      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5566          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5567      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5568        enddo
5569 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5570 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5571
5572 C to check gradient call subroutine check_grad
5573
5574     1 continue
5575       enddo
5576       return
5577       end
5578 #endif
5579 c------------------------------------------------------------------------------
5580       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5581 C
5582 C This procedure calculates two-body contact function g(rij) and its derivative:
5583 C
5584 C           eps0ij                                     !       x < -1
5585 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5586 C            0                                         !       x > 1
5587 C
5588 C where x=(rij-r0ij)/delta
5589 C
5590 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5591 C
5592       implicit none
5593       double precision rij,r0ij,eps0ij,fcont,fprimcont
5594       double precision x,x2,x4,delta
5595 c     delta=0.02D0*r0ij
5596 c      delta=0.2D0*r0ij
5597       x=(rij-r0ij)/delta
5598       if (x.lt.-1.0D0) then
5599         fcont=eps0ij
5600         fprimcont=0.0D0
5601       else if (x.le.1.0D0) then
5602         x2=x*x
5603         x4=x2*x2
5604         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5605         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5606       else
5607         fcont=0.0D0
5608         fprimcont=0.0D0
5609       endif
5610       return
5611       end
5612 c------------------------------------------------------------------------------
5613       subroutine splinthet(theti,delta,ss,ssder)
5614       implicit real*8 (a-h,o-z)
5615       include 'DIMENSIONS'
5616       include 'COMMON.VAR'
5617       include 'COMMON.GEO'
5618       thetup=pi-delta
5619       thetlow=delta
5620       if (theti.gt.pipol) then
5621         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5622       else
5623         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5624         ssder=-ssder
5625       endif
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5630       implicit none
5631       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5632       double precision ksi,ksi2,ksi3,a1,a2,a3
5633       a1=fprim0*delta/(f1-f0)
5634       a2=3.0d0-2.0d0*a1
5635       a3=a1-2.0d0
5636       ksi=(x-x0)/delta
5637       ksi2=ksi*ksi
5638       ksi3=ksi2*ksi
5639       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5640       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5641       return
5642       end
5643 c------------------------------------------------------------------------------
5644       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5645       implicit none
5646       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5647       double precision ksi,ksi2,ksi3,a1,a2,a3
5648       ksi=(x-x0)/delta
5649       ksi2=ksi*ksi
5650       ksi3=ksi2*ksi
5651       a1=fprim0x*delta
5652       a2=3*(f1x-f0x)-2*fprim0x*delta
5653       a3=fprim0x*delta-2*(f1x-f0x)
5654       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5655       return
5656       end
5657 C-----------------------------------------------------------------------------
5658 #ifdef CRYST_TOR
5659 C-----------------------------------------------------------------------------
5660       subroutine etor(etors,fact)
5661       implicit real*8 (a-h,o-z)
5662       include 'DIMENSIONS'
5663       include 'COMMON.VAR'
5664       include 'COMMON.GEO'
5665       include 'COMMON.LOCAL'
5666       include 'COMMON.TORSION'
5667       include 'COMMON.INTERACT'
5668       include 'COMMON.DERIV'
5669       include 'COMMON.CHAIN'
5670       include 'COMMON.NAMES'
5671       include 'COMMON.IOUNITS'
5672       include 'COMMON.FFIELD'
5673       include 'COMMON.TORCNSTR'
5674       logical lprn
5675 C Set lprn=.true. for debugging
5676       lprn=.false.
5677 c      lprn=.true.
5678       etors=0.0D0
5679       do i=iphi_start,iphi_end
5680         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5681      &      .or. itype(i).eq.ntyp1) cycle
5682         itori=itortyp(itype(i-2))
5683         itori1=itortyp(itype(i-1))
5684         phii=phi(i)
5685         gloci=0.0D0
5686 C Proline-Proline pair is a special case...
5687         if (itori.eq.3 .and. itori1.eq.3) then
5688           if (phii.gt.-dwapi3) then
5689             cosphi=dcos(3*phii)
5690             fac=1.0D0/(1.0D0-cosphi)
5691             etorsi=v1(1,3,3)*fac
5692             etorsi=etorsi+etorsi
5693             etors=etors+etorsi-v1(1,3,3)
5694             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5695           endif
5696           do j=1,3
5697             v1ij=v1(j+1,itori,itori1)
5698             v2ij=v2(j+1,itori,itori1)
5699             cosphi=dcos(j*phii)
5700             sinphi=dsin(j*phii)
5701             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5702             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5703           enddo
5704         else
5705           do j=1,nterm_old
5706             v1ij=v1(j,itori,itori1)
5707             v2ij=v2(j,itori,itori1)
5708             cosphi=dcos(j*phii)
5709             sinphi=dsin(j*phii)
5710             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5711             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5712           enddo
5713         endif
5714         if (lprn)
5715      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5716      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5717      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5718         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5719 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5720       enddo
5721       return
5722       end
5723 c------------------------------------------------------------------------------
5724 #else
5725       subroutine etor(etors,fact)
5726       implicit real*8 (a-h,o-z)
5727       include 'DIMENSIONS'
5728       include 'COMMON.VAR'
5729       include 'COMMON.GEO'
5730       include 'COMMON.LOCAL'
5731       include 'COMMON.TORSION'
5732       include 'COMMON.INTERACT'
5733       include 'COMMON.DERIV'
5734       include 'COMMON.CHAIN'
5735       include 'COMMON.NAMES'
5736       include 'COMMON.IOUNITS'
5737       include 'COMMON.FFIELD'
5738       include 'COMMON.TORCNSTR'
5739       logical lprn
5740 C Set lprn=.true. for debugging
5741       lprn=.false.
5742 c      lprn=.true.
5743       etors=0.0D0
5744       do i=iphi_start,iphi_end
5745         if (i.le.2) cycle
5746         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5747      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5748 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5749 C     &       .or. itype(i).eq.ntyp1) cycle
5750         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5751          if (iabs(itype(i)).eq.20) then
5752          iblock=2
5753          else
5754          iblock=1
5755          endif
5756         itori=itortyp(itype(i-2))
5757         itori1=itortyp(itype(i-1))
5758         phii=phi(i)
5759         gloci=0.0D0
5760 C Regular cosine and sine terms
5761         do j=1,nterm(itori,itori1,iblock)
5762           v1ij=v1(j,itori,itori1,iblock)
5763           v2ij=v2(j,itori,itori1,iblock)
5764           cosphi=dcos(j*phii)
5765           sinphi=dsin(j*phii)
5766           etors=etors+v1ij*cosphi+v2ij*sinphi
5767           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5768         enddo
5769 C Lorentz terms
5770 C                         v1
5771 C  E = SUM ----------------------------------- - v1
5772 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5773 C
5774         cosphi=dcos(0.5d0*phii)
5775         sinphi=dsin(0.5d0*phii)
5776         do j=1,nlor(itori,itori1,iblock)
5777           vl1ij=vlor1(j,itori,itori1)
5778           vl2ij=vlor2(j,itori,itori1)
5779           vl3ij=vlor3(j,itori,itori1)
5780           pom=vl2ij*cosphi+vl3ij*sinphi
5781           pom1=1.0d0/(pom*pom+1.0d0)
5782           etors=etors+vl1ij*pom1
5783 c          if (energy_dec) etors_ii=etors_ii+
5784 c     &                vl1ij*pom1
5785           pom=-pom*pom1*pom1
5786           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5787         enddo
5788 C Subtract the constant term
5789         etors=etors-v0(itori,itori1,iblock)
5790         if (lprn)
5791      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5792      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5793      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5794         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5795 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5796  1215   continue
5797       enddo
5798       return
5799       end
5800 c----------------------------------------------------------------------------
5801       subroutine etor_d(etors_d,fact2)
5802 C 6/23/01 Compute double torsional energy
5803       implicit real*8 (a-h,o-z)
5804       include 'DIMENSIONS'
5805       include 'COMMON.VAR'
5806       include 'COMMON.GEO'
5807       include 'COMMON.LOCAL'
5808       include 'COMMON.TORSION'
5809       include 'COMMON.INTERACT'
5810       include 'COMMON.DERIV'
5811       include 'COMMON.CHAIN'
5812       include 'COMMON.NAMES'
5813       include 'COMMON.IOUNITS'
5814       include 'COMMON.FFIELD'
5815       include 'COMMON.TORCNSTR'
5816       logical lprn
5817 C Set lprn=.true. for debugging
5818       lprn=.false.
5819 c     lprn=.true.
5820       etors_d=0.0D0
5821       do i=iphi_start,iphi_end-1
5822         if (i.le.3) cycle
5823 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5824 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5825          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5826      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5827      &  (itype(i+1).eq.ntyp1)) cycle
5828         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5829      &     goto 1215
5830         itori=itortyp(itype(i-2))
5831         itori1=itortyp(itype(i-1))
5832         itori2=itortyp(itype(i))
5833         phii=phi(i)
5834         phii1=phi(i+1)
5835         gloci1=0.0D0
5836         gloci2=0.0D0
5837         iblock=1
5838         if (iabs(itype(i+1)).eq.20) iblock=2
5839 C Regular cosine and sine terms
5840         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5841           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5842           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5843           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5844           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5845           cosphi1=dcos(j*phii)
5846           sinphi1=dsin(j*phii)
5847           cosphi2=dcos(j*phii1)
5848           sinphi2=dsin(j*phii1)
5849           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5850      &     v2cij*cosphi2+v2sij*sinphi2
5851           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5852           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5853         enddo
5854         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5855           do l=1,k-1
5856             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5857             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5858             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5859             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5860             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5861             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5862             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5863             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5864             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5865      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5866             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5867      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5868             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5869      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5870           enddo
5871         enddo
5872         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5873         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5874  1215   continue
5875       enddo
5876       return
5877       end
5878 #endif
5879 c---------------------------------------------------------------------------
5880 C The rigorous attempt to derive energy function
5881       subroutine etor_kcc(etors,fact)
5882       implicit real*8 (a-h,o-z)
5883       include 'DIMENSIONS'
5884       include 'COMMON.VAR'
5885       include 'COMMON.GEO'
5886       include 'COMMON.LOCAL'
5887       include 'COMMON.TORSION'
5888       include 'COMMON.INTERACT'
5889       include 'COMMON.DERIV'
5890       include 'COMMON.CHAIN'
5891       include 'COMMON.NAMES'
5892       include 'COMMON.IOUNITS'
5893       include 'COMMON.FFIELD'
5894       include 'COMMON.TORCNSTR'
5895       include 'COMMON.CONTROL'
5896       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5897       logical lprn
5898 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5899 C Set lprn=.true. for debugging
5900       lprn=energy_dec
5901 c     lprn=.true.
5902 C      print *,"wchodze kcc"
5903       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5904       etors=0.0D0
5905       do i=iphi_start,iphi_end
5906 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5907 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5908 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5909 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5910         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5911      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5912         itori=itortyp(itype(i-2))
5913         itori1=itortyp(itype(i-1))
5914         phii=phi(i)
5915         glocig=0.0D0
5916         glocit1=0.0d0
5917         glocit2=0.0d0
5918 C to avoid multiple devision by 2
5919 c        theti22=0.5d0*theta(i)
5920 C theta 12 is the theta_1 /2
5921 C theta 22 is theta_2 /2
5922 c        theti12=0.5d0*theta(i-1)
5923 C and appropriate sinus function
5924         sinthet1=dsin(theta(i-1))
5925         sinthet2=dsin(theta(i))
5926         costhet1=dcos(theta(i-1))
5927         costhet2=dcos(theta(i))
5928 C to speed up lets store its mutliplication
5929         sint1t2=sinthet2*sinthet1
5930         sint1t2n=1.0d0
5931 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5932 C +d_n*sin(n*gamma)) *
5933 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5934 C we have two sum 1) Non-Chebyshev which is with n and gamma
5935         nval=nterm_kcc_Tb(itori,itori1)
5936         c1(0)=0.0d0
5937         c2(0)=0.0d0
5938         c1(1)=1.0d0
5939         c2(1)=1.0d0
5940         do j=2,nval
5941           c1(j)=c1(j-1)*costhet1
5942           c2(j)=c2(j-1)*costhet2
5943         enddo
5944         etori=0.0d0
5945         do j=1,nterm_kcc(itori,itori1)
5946           cosphi=dcos(j*phii)
5947           sinphi=dsin(j*phii)
5948           sint1t2n1=sint1t2n
5949           sint1t2n=sint1t2n*sint1t2
5950           sumvalc=0.0d0
5951           gradvalct1=0.0d0
5952           gradvalct2=0.0d0
5953           do k=1,nval
5954             do l=1,nval
5955               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5956               gradvalct1=gradvalct1+
5957      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5958               gradvalct2=gradvalct2+
5959      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5960             enddo
5961           enddo
5962           gradvalct1=-gradvalct1*sinthet1
5963           gradvalct2=-gradvalct2*sinthet2
5964           sumvals=0.0d0
5965           gradvalst1=0.0d0
5966           gradvalst2=0.0d0
5967           do k=1,nval
5968             do l=1,nval
5969               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5970               gradvalst1=gradvalst1+
5971      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5972               gradvalst2=gradvalst2+
5973      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5974             enddo
5975           enddo
5976           gradvalst1=-gradvalst1*sinthet1
5977           gradvalst2=-gradvalst2*sinthet2
5978           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5979 C glocig is the gradient local i site in gamma
5980           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5981 C now gradient over theta_1
5982           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5983      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5984           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5985      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5986         enddo ! j
5987         etors=etors+etori
5988 C derivative over gamma
5989         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
5990 C derivative over theta1
5991         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
5992 C now derivative over theta2
5993         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
5994         if (lprn)
5995      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
5996      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
5997       enddo
5998       return
5999       end
6000 c---------------------------------------------------------------------------------------------
6001       subroutine etor_constr(edihcnstr)
6002       implicit real*8 (a-h,o-z)
6003       include 'DIMENSIONS'
6004       include 'COMMON.VAR'
6005       include 'COMMON.GEO'
6006       include 'COMMON.LOCAL'
6007       include 'COMMON.TORSION'
6008       include 'COMMON.INTERACT'
6009       include 'COMMON.DERIV'
6010       include 'COMMON.CHAIN'
6011       include 'COMMON.NAMES'
6012       include 'COMMON.IOUNITS'
6013       include 'COMMON.FFIELD'
6014       include 'COMMON.TORCNSTR'
6015       include 'COMMON.CONTROL'
6016 ! 6/20/98 - dihedral angle constraints
6017       edihcnstr=0.0d0
6018 c      do i=1,ndih_constr
6019 c      write (iout,*) "idihconstr_start",idihconstr_start,
6020 c     &  " idihconstr_end",idihconstr_end
6021       if (raw_psipred) then
6022         do i=idihconstr_start,idihconstr_end
6023           itori=idih_constr(i)
6024           phii=phi(itori)
6025           gaudih_i=vpsipred(1,i)
6026           gauder_i=0.0d0
6027           do j=1,2
6028             s = sdihed(j,i)
6029             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6030             dexpcos_i=dexp(-cos_i*cos_i)
6031             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6032             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6033      &            *cos_i*dexpcos_i/s**2
6034           enddo
6035           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6036           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6037           if (energy_dec)
6038      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6039      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6040      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6041      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6042      &     -wdihc*dlog(gaudih_i)
6043         enddo
6044       else
6045         do i=idihconstr_start,idihconstr_end
6046           itori=idih_constr(i)
6047           phii=phi(itori)
6048           difi=pinorm(phii-phi0(i))
6049           if (difi.gt.drange(i)) then
6050             difi=difi-drange(i)
6051             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6052             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6053           else if (difi.lt.-drange(i)) then
6054             difi=difi+drange(i)
6055             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6056             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6057           else
6058             difi=0.0
6059           endif
6060         enddo
6061       endif
6062       return
6063       end
6064 c----------------------------------------------------------------------------
6065 C The rigorous attempt to derive energy function
6066       subroutine ebend_kcc(etheta)
6067
6068       implicit real*8 (a-h,o-z)
6069       include 'DIMENSIONS'
6070       include 'COMMON.VAR'
6071       include 'COMMON.GEO'
6072       include 'COMMON.LOCAL'
6073       include 'COMMON.TORSION'
6074       include 'COMMON.INTERACT'
6075       include 'COMMON.DERIV'
6076       include 'COMMON.CHAIN'
6077       include 'COMMON.NAMES'
6078       include 'COMMON.IOUNITS'
6079       include 'COMMON.FFIELD'
6080       include 'COMMON.TORCNSTR'
6081       include 'COMMON.CONTROL'
6082       logical lprn
6083       double precision thybt1(maxang_kcc)
6084 C Set lprn=.true. for debugging
6085       lprn=energy_dec
6086 c     lprn=.true.
6087 C      print *,"wchodze kcc"
6088       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6089       etheta=0.0D0
6090       do i=ithet_start,ithet_end
6091 c        print *,i,itype(i-1),itype(i),itype(i-2)
6092         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6093      &  .or.itype(i).eq.ntyp1) cycle
6094         iti=iabs(itortyp(itype(i-1)))
6095         sinthet=dsin(theta(i))
6096         costhet=dcos(theta(i))
6097         do j=1,nbend_kcc_Tb(iti)
6098           thybt1(j)=v1bend_chyb(j,iti)
6099         enddo
6100         sumth1thyb=v1bend_chyb(0,iti)+
6101      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6102         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6103      &    sumth1thyb
6104         ihelp=nbend_kcc_Tb(iti)-1
6105         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6106         etheta=etheta+sumth1thyb
6107 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6108         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6109       enddo
6110       return
6111       end
6112 c-------------------------------------------------------------------------------------
6113       subroutine etheta_constr(ethetacnstr)
6114
6115       implicit real*8 (a-h,o-z)
6116       include 'DIMENSIONS'
6117       include 'COMMON.VAR'
6118       include 'COMMON.GEO'
6119       include 'COMMON.LOCAL'
6120       include 'COMMON.TORSION'
6121       include 'COMMON.INTERACT'
6122       include 'COMMON.DERIV'
6123       include 'COMMON.CHAIN'
6124       include 'COMMON.NAMES'
6125       include 'COMMON.IOUNITS'
6126       include 'COMMON.FFIELD'
6127       include 'COMMON.TORCNSTR'
6128       include 'COMMON.CONTROL'
6129       ethetacnstr=0.0d0
6130 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6131       do i=ithetaconstr_start,ithetaconstr_end
6132         itheta=itheta_constr(i)
6133         thetiii=theta(itheta)
6134         difi=pinorm(thetiii-theta_constr0(i))
6135         if (difi.gt.theta_drange(i)) then
6136           difi=difi-theta_drange(i)
6137           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6138           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6139      &    +for_thet_constr(i)*difi**3
6140         else if (difi.lt.-drange(i)) then
6141           difi=difi+drange(i)
6142           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6143           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6144      &    +for_thet_constr(i)*difi**3
6145         else
6146           difi=0.0
6147         endif
6148        if (energy_dec) then
6149         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6150      &    i,itheta,rad2deg*thetiii,
6151      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6152      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6153      &    gloc(itheta+nphi-2,icg)
6154         endif
6155       enddo
6156       return
6157       end
6158 c------------------------------------------------------------------------------
6159 c------------------------------------------------------------------------------
6160       subroutine eback_sc_corr(esccor)
6161 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6162 c        conformational states; temporarily implemented as differences
6163 c        between UNRES torsional potentials (dependent on three types of
6164 c        residues) and the torsional potentials dependent on all 20 types
6165 c        of residues computed from AM1 energy surfaces of terminally-blocked
6166 c        amino-acid residues.
6167       implicit real*8 (a-h,o-z)
6168       include 'DIMENSIONS'
6169       include 'COMMON.VAR'
6170       include 'COMMON.GEO'
6171       include 'COMMON.LOCAL'
6172       include 'COMMON.TORSION'
6173       include 'COMMON.SCCOR'
6174       include 'COMMON.INTERACT'
6175       include 'COMMON.DERIV'
6176       include 'COMMON.CHAIN'
6177       include 'COMMON.NAMES'
6178       include 'COMMON.IOUNITS'
6179       include 'COMMON.FFIELD'
6180       include 'COMMON.CONTROL'
6181       logical lprn
6182 C Set lprn=.true. for debugging
6183       lprn=.false.
6184 c      lprn=.true.
6185 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6186       esccor=0.0D0
6187       do i=itau_start,itau_end
6188         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6189         esccor_ii=0.0D0
6190         isccori=isccortyp(itype(i-2))
6191         isccori1=isccortyp(itype(i-1))
6192         phii=phi(i)
6193         do intertyp=1,3 !intertyp
6194 cc Added 09 May 2012 (Adasko)
6195 cc  Intertyp means interaction type of backbone mainchain correlation:
6196 c   1 = SC...Ca...Ca...Ca
6197 c   2 = Ca...Ca...Ca...SC
6198 c   3 = SC...Ca...Ca...SCi
6199         gloci=0.0D0
6200         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6201      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6202      &      (itype(i-1).eq.ntyp1)))
6203      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6204      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6205      &     .or.(itype(i).eq.ntyp1)))
6206      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6207      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6208      &      (itype(i-3).eq.ntyp1)))) cycle
6209         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6210         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6211      & cycle
6212        do j=1,nterm_sccor(isccori,isccori1)
6213           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6214           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6215           cosphi=dcos(j*tauangle(intertyp,i))
6216           sinphi=dsin(j*tauangle(intertyp,i))
6217            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6218            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6219          enddo
6220 C      write (iout,*)"EBACK_SC_COR",esccor,i
6221 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6222 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6223 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6224         if (lprn)
6225      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6226      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6227      &  (v1sccor(j,1,itori,itori1),j=1,6)
6228      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6229 c        gsccor_loc(i-3)=gloci
6230        enddo !intertyp
6231       enddo
6232       return
6233       end
6234 c------------------------------------------------------------------------------
6235       subroutine multibody(ecorr)
6236 C This subroutine calculates multi-body contributions to energy following
6237 C the idea of Skolnick et al. If side chains I and J make a contact and
6238 C at the same time side chains I+1 and J+1 make a contact, an extra
6239 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6240       implicit real*8 (a-h,o-z)
6241       include 'DIMENSIONS'
6242       include 'COMMON.IOUNITS'
6243       include 'COMMON.DERIV'
6244       include 'COMMON.INTERACT'
6245       include 'COMMON.CONTACTS'
6246       double precision gx(3),gx1(3)
6247       logical lprn
6248
6249 C Set lprn=.true. for debugging
6250       lprn=.false.
6251
6252       if (lprn) then
6253         write (iout,'(a)') 'Contact function values:'
6254         do i=nnt,nct-2
6255           write (iout,'(i2,20(1x,i2,f10.5))')
6256      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6257         enddo
6258       endif
6259       ecorr=0.0D0
6260       do i=nnt,nct
6261         do j=1,3
6262           gradcorr(j,i)=0.0D0
6263           gradxorr(j,i)=0.0D0
6264         enddo
6265       enddo
6266       do i=nnt,nct-2
6267
6268         DO ISHIFT = 3,4
6269
6270         i1=i+ishift
6271         num_conti=num_cont(i)
6272         num_conti1=num_cont(i1)
6273         do jj=1,num_conti
6274           j=jcont(jj,i)
6275           do kk=1,num_conti1
6276             j1=jcont(kk,i1)
6277             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6278 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6279 cd   &                   ' ishift=',ishift
6280 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6281 C The system gains extra energy.
6282               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6283             endif   ! j1==j+-ishift
6284           enddo     ! kk
6285         enddo       ! jj
6286
6287         ENDDO ! ISHIFT
6288
6289       enddo         ! i
6290       return
6291       end
6292 c------------------------------------------------------------------------------
6293       double precision function esccorr(i,j,k,l,jj,kk)
6294       implicit real*8 (a-h,o-z)
6295       include 'DIMENSIONS'
6296       include 'COMMON.IOUNITS'
6297       include 'COMMON.DERIV'
6298       include 'COMMON.INTERACT'
6299       include 'COMMON.CONTACTS'
6300       double precision gx(3),gx1(3)
6301       logical lprn
6302       lprn=.false.
6303       eij=facont(jj,i)
6304       ekl=facont(kk,k)
6305 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6306 C Calculate the multi-body contribution to energy.
6307 C Calculate multi-body contributions to the gradient.
6308 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6309 cd   & k,l,(gacont(m,kk,k),m=1,3)
6310       do m=1,3
6311         gx(m) =ekl*gacont(m,jj,i)
6312         gx1(m)=eij*gacont(m,kk,k)
6313         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6314         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6315         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6316         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6317       enddo
6318       do m=i,j-1
6319         do ll=1,3
6320           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6321         enddo
6322       enddo
6323       do m=k,l-1
6324         do ll=1,3
6325           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6326         enddo
6327       enddo
6328       esccorr=-eij*ekl
6329       return
6330       end
6331 c------------------------------------------------------------------------------
6332       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6333 C This subroutine calculates multi-body contributions to hydrogen-bonding
6334       implicit real*8 (a-h,o-z)
6335       include 'DIMENSIONS'
6336       include 'COMMON.IOUNITS'
6337       include 'COMMON.FFIELD'
6338       include 'COMMON.DERIV'
6339       include 'COMMON.INTERACT'
6340       include 'COMMON.CONTACTS'
6341       double precision gx(3),gx1(3)
6342       logical lprn,ldone
6343
6344 C Set lprn=.true. for debugging
6345       lprn=.false.
6346       if (lprn) then
6347         write (iout,'(a)') 'Contact function values:'
6348         do i=nnt,nct-2
6349           write (iout,'(2i3,50(1x,i2,f5.2))')
6350      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6351      &    j=1,num_cont_hb(i))
6352         enddo
6353       endif
6354       ecorr=0.0D0
6355 C Remove the loop below after debugging !!!
6356       do i=nnt,nct
6357         do j=1,3
6358           gradcorr(j,i)=0.0D0
6359           gradxorr(j,i)=0.0D0
6360         enddo
6361       enddo
6362 C Calculate the local-electrostatic correlation terms
6363       do i=iatel_s,iatel_e+1
6364         i1=i+1
6365         num_conti=num_cont_hb(i)
6366         num_conti1=num_cont_hb(i+1)
6367         do jj=1,num_conti
6368           j=jcont_hb(jj,i)
6369           do kk=1,num_conti1
6370             j1=jcont_hb(kk,i1)
6371 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6372 c     &         ' jj=',jj,' kk=',kk
6373             if (j1.eq.j+1 .or. j1.eq.j-1) then
6374 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6375 C The system gains extra energy.
6376               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6377               n_corr=n_corr+1
6378             else if (j1.eq.j) then
6379 C Contacts I-J and I-(J+1) occur simultaneously.
6380 C The system loses extra energy.
6381 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6382             endif
6383           enddo ! kk
6384           do kk=1,num_conti
6385             j1=jcont_hb(kk,i)
6386 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6387 c    &         ' jj=',jj,' kk=',kk
6388             if (j1.eq.j+1) then
6389 C Contacts I-J and (I+1)-J occur simultaneously.
6390 C The system loses extra energy.
6391 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6392             endif ! j1==j+1
6393           enddo ! kk
6394         enddo ! jj
6395       enddo ! i
6396       return
6397       end
6398 c------------------------------------------------------------------------------
6399       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6400      &  n_corr1)
6401 C This subroutine calculates multi-body contributions to hydrogen-bonding
6402       implicit real*8 (a-h,o-z)
6403       include 'DIMENSIONS'
6404       include 'COMMON.IOUNITS'
6405 #ifdef MPI
6406       include "mpif.h"
6407 #endif
6408       include 'COMMON.FFIELD'
6409       include 'COMMON.DERIV'
6410       include 'COMMON.LOCAL'
6411       include 'COMMON.INTERACT'
6412       include 'COMMON.CONTACTS'
6413       include 'COMMON.CHAIN'
6414       include 'COMMON.CONTROL'
6415       include 'COMMON.SHIELD'
6416       double precision gx(3),gx1(3)
6417       integer num_cont_hb_old(maxres)
6418       logical lprn,ldone
6419       double precision eello4,eello5,eelo6,eello_turn6
6420       external eello4,eello5,eello6,eello_turn6
6421 C Set lprn=.true. for debugging
6422       lprn=.false.
6423       eturn6=0.0d0
6424       if (lprn) then
6425         write (iout,'(a)') 'Contact function values:'
6426         do i=nnt,nct-2
6427           write (iout,'(2i3,50(1x,i2,5f6.3))')
6428      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6429      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6430         enddo
6431       endif
6432       ecorr=0.0D0
6433       ecorr5=0.0d0
6434       ecorr6=0.0d0
6435 C Remove the loop below after debugging !!!
6436       do i=nnt,nct
6437         do j=1,3
6438           gradcorr(j,i)=0.0D0
6439           gradxorr(j,i)=0.0D0
6440         enddo
6441       enddo
6442 C Calculate the dipole-dipole interaction energies
6443       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6444       do i=iatel_s,iatel_e+1
6445         num_conti=num_cont_hb(i)
6446         do jj=1,num_conti
6447           j=jcont_hb(jj,i)
6448 #ifdef MOMENT
6449           call dipole(i,j,jj)
6450 #endif
6451         enddo
6452       enddo
6453       endif
6454 C Calculate the local-electrostatic correlation terms
6455 c                write (iout,*) "gradcorr5 in eello5 before loop"
6456 c                do iii=1,nres
6457 c                  write (iout,'(i5,3f10.5)')
6458 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6459 c                enddo
6460       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6461 c        write (iout,*) "corr loop i",i
6462         i1=i+1
6463         num_conti=num_cont_hb(i)
6464         num_conti1=num_cont_hb(i+1)
6465         do jj=1,num_conti
6466           j=jcont_hb(jj,i)
6467           jp=iabs(j)
6468           do kk=1,num_conti1
6469             j1=jcont_hb(kk,i1)
6470             jp1=iabs(j1)
6471 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6472 c     &         ' jj=',jj,' kk=',kk
6473 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6474             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6475      &          .or. j.lt.0 .and. j1.gt.0) .and.
6476      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6477 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6478 C The system gains extra energy.
6479               n_corr=n_corr+1
6480               sqd1=dsqrt(d_cont(jj,i))
6481               sqd2=dsqrt(d_cont(kk,i1))
6482               sred_geom = sqd1*sqd2
6483               IF (sred_geom.lt.cutoff_corr) THEN
6484                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6485      &            ekont,fprimcont)
6486 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6487 cd     &         ' jj=',jj,' kk=',kk
6488                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6489                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6490                 do l=1,3
6491                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6492                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6493                 enddo
6494                 n_corr1=n_corr1+1
6495 cd               write (iout,*) 'sred_geom=',sred_geom,
6496 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6497 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6498 cd               write (iout,*) "g_contij",g_contij
6499 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6500 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6501                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6502                 if (wcorr4.gt.0.0d0)
6503      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6504 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6505                   if (energy_dec.and.wcorr4.gt.0.0d0)
6506      1                 write (iout,'(a6,4i5,0pf7.3)')
6507      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6508 c                write (iout,*) "gradcorr5 before eello5"
6509 c                do iii=1,nres
6510 c                  write (iout,'(i5,3f10.5)')
6511 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6512 c                enddo
6513                 if (wcorr5.gt.0.0d0)
6514      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6515 c                write (iout,*) "gradcorr5 after eello5"
6516 c                do iii=1,nres
6517 c                  write (iout,'(i5,3f10.5)')
6518 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6519 c                enddo
6520                   if (energy_dec.and.wcorr5.gt.0.0d0)
6521      1                 write (iout,'(a6,4i5,0pf7.3)')
6522      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6523 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6524 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6525                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6526      &               .or. wturn6.eq.0.0d0))then
6527 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6528                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6529                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6530      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6531 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6532 cd     &            'ecorr6=',ecorr6
6533 cd                write (iout,'(4e15.5)') sred_geom,
6534 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6535 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6536 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6537                 else if (wturn6.gt.0.0d0
6538      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6539 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6540                   eturn6=eturn6+eello_turn6(i,jj,kk)
6541                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6542      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6543 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6544                 endif
6545               ENDIF
6546 1111          continue
6547             endif
6548           enddo ! kk
6549         enddo ! jj
6550       enddo ! i
6551       do i=1,nres
6552         num_cont_hb(i)=num_cont_hb_old(i)
6553       enddo
6554 c                write (iout,*) "gradcorr5 in eello5"
6555 c                do iii=1,nres
6556 c                  write (iout,'(i5,3f10.5)')
6557 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6558 c                enddo
6559       return
6560       end
6561 c------------------------------------------------------------------------------
6562       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6563       implicit real*8 (a-h,o-z)
6564       include 'DIMENSIONS'
6565       include 'COMMON.IOUNITS'
6566       include 'COMMON.DERIV'
6567       include 'COMMON.INTERACT'
6568       include 'COMMON.CONTACTS'
6569       include 'COMMON.SHIELD'
6570       include 'COMMON.CONTROL'
6571       double precision gx(3),gx1(3)
6572       logical lprn
6573       lprn=.false.
6574 C      print *,"wchodze",fac_shield(i),shield_mode
6575       eij=facont_hb(jj,i)
6576       ekl=facont_hb(kk,k)
6577       ees0pij=ees0p(jj,i)
6578       ees0pkl=ees0p(kk,k)
6579       ees0mij=ees0m(jj,i)
6580       ees0mkl=ees0m(kk,k)
6581       ekont=eij*ekl
6582       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6583 C*
6584 C     & fac_shield(i)**2*fac_shield(j)**2
6585 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6586 C Following 4 lines for diagnostics.
6587 cd    ees0pkl=0.0D0
6588 cd    ees0pij=1.0D0
6589 cd    ees0mkl=0.0D0
6590 cd    ees0mij=1.0D0
6591 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6592 c     & 'Contacts ',i,j,
6593 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6594 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6595 c     & 'gradcorr_long'
6596 C Calculate the multi-body contribution to energy.
6597 C      ecorr=ecorr+ekont*ees
6598 C Calculate multi-body contributions to the gradient.
6599       coeffpees0pij=coeffp*ees0pij
6600       coeffmees0mij=coeffm*ees0mij
6601       coeffpees0pkl=coeffp*ees0pkl
6602       coeffmees0mkl=coeffm*ees0mkl
6603       do ll=1,3
6604 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6605         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6606      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6607      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6608         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6609      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6610      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6611 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6612         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6613      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6614      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6615         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6616      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6617      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6618         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6619      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6620      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6621         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6622         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6623         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6624      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6625      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6626         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6627         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6628 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6629       enddo
6630 c      write (iout,*)
6631 cgrad      do m=i+1,j-1
6632 cgrad        do ll=1,3
6633 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6634 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6635 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6636 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6637 cgrad        enddo
6638 cgrad      enddo
6639 cgrad      do m=k+1,l-1
6640 cgrad        do ll=1,3
6641 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6642 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6643 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6644 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6645 cgrad        enddo
6646 cgrad      enddo
6647 c      write (iout,*) "ehbcorr",ekont*ees
6648 C      print *,ekont,ees,i,k
6649       ehbcorr=ekont*ees
6650 C now gradient over shielding
6651 C      return
6652       if (shield_mode.gt.0) then
6653        j=ees0plist(jj,i)
6654        l=ees0plist(kk,k)
6655 C        print *,i,j,fac_shield(i),fac_shield(j),
6656 C     &fac_shield(k),fac_shield(l)
6657         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6658      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6659           do ilist=1,ishield_list(i)
6660            iresshield=shield_list(ilist,i)
6661            do m=1,3
6662            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6663 C     &      *2.0
6664            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6665      &              rlocshield
6666      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6667             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6668      &+rlocshield
6669            enddo
6670           enddo
6671           do ilist=1,ishield_list(j)
6672            iresshield=shield_list(ilist,j)
6673            do m=1,3
6674            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6675 C     &     *2.0
6676            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6677      &              rlocshield
6678      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6679            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6680      &     +rlocshield
6681            enddo
6682           enddo
6683
6684           do ilist=1,ishield_list(k)
6685            iresshield=shield_list(ilist,k)
6686            do m=1,3
6687            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6688 C     &     *2.0
6689            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6690      &              rlocshield
6691      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6692            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6693      &     +rlocshield
6694            enddo
6695           enddo
6696           do ilist=1,ishield_list(l)
6697            iresshield=shield_list(ilist,l)
6698            do m=1,3
6699            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6700 C     &     *2.0
6701            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6702      &              rlocshield
6703      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6704            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6705      &     +rlocshield
6706            enddo
6707           enddo
6708 C          print *,gshieldx(m,iresshield)
6709           do m=1,3
6710             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6711      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6712             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6713      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6714             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6715      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6716             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6717      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6718
6719             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6720      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6721             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6722      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6723             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6724      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6725             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6726      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6727
6728            enddo
6729       endif
6730       endif
6731       return
6732       end
6733 #ifdef MOMENT
6734 C---------------------------------------------------------------------------
6735       subroutine dipole(i,j,jj)
6736       implicit real*8 (a-h,o-z)
6737       include 'DIMENSIONS'
6738       include 'COMMON.IOUNITS'
6739       include 'COMMON.CHAIN'
6740       include 'COMMON.FFIELD'
6741       include 'COMMON.DERIV'
6742       include 'COMMON.INTERACT'
6743       include 'COMMON.CONTACTS'
6744       include 'COMMON.TORSION'
6745       include 'COMMON.VAR'
6746       include 'COMMON.GEO'
6747       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6748      &  auxmat(2,2)
6749       iti1 = itortyp(itype(i+1))
6750       if (j.lt.nres-1) then
6751         itj1 = itype2loc(itype(j+1))
6752       else
6753         itj1=nloctyp
6754       endif
6755       do iii=1,2
6756         dipi(iii,1)=Ub2(iii,i)
6757         dipderi(iii)=Ub2der(iii,i)
6758         dipi(iii,2)=b1(iii,i+1)
6759         dipj(iii,1)=Ub2(iii,j)
6760         dipderj(iii)=Ub2der(iii,j)
6761         dipj(iii,2)=b1(iii,j+1)
6762       enddo
6763       kkk=0
6764       do iii=1,2
6765         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6766         do jjj=1,2
6767           kkk=kkk+1
6768           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6769         enddo
6770       enddo
6771       do kkk=1,5
6772         do lll=1,3
6773           mmm=0
6774           do iii=1,2
6775             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6776      &        auxvec(1))
6777             do jjj=1,2
6778               mmm=mmm+1
6779               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6780             enddo
6781           enddo
6782         enddo
6783       enddo
6784       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6785       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6786       do iii=1,2
6787         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6788       enddo
6789       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6790       do iii=1,2
6791         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6792       enddo
6793       return
6794       end
6795 #endif
6796 C---------------------------------------------------------------------------
6797       subroutine calc_eello(i,j,k,l,jj,kk)
6798 C
6799 C This subroutine computes matrices and vectors needed to calculate
6800 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6801 C
6802       implicit real*8 (a-h,o-z)
6803       include 'DIMENSIONS'
6804       include 'COMMON.IOUNITS'
6805       include 'COMMON.CHAIN'
6806       include 'COMMON.DERIV'
6807       include 'COMMON.INTERACT'
6808       include 'COMMON.CONTACTS'
6809       include 'COMMON.TORSION'
6810       include 'COMMON.VAR'
6811       include 'COMMON.GEO'
6812       include 'COMMON.FFIELD'
6813       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6814      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6815       logical lprn
6816       common /kutas/ lprn
6817 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6818 cd     & ' jj=',jj,' kk=',kk
6819 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6820 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6821 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6822       do iii=1,2
6823         do jjj=1,2
6824           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6825           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6826         enddo
6827       enddo
6828       call transpose2(aa1(1,1),aa1t(1,1))
6829       call transpose2(aa2(1,1),aa2t(1,1))
6830       do kkk=1,5
6831         do lll=1,3
6832           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6833      &      aa1tder(1,1,lll,kkk))
6834           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6835      &      aa2tder(1,1,lll,kkk))
6836         enddo
6837       enddo
6838       if (l.eq.j+1) then
6839 C parallel orientation of the two CA-CA-CA frames.
6840         if (i.gt.1) then
6841           iti=itype2loc(itype(i))
6842         else
6843           iti=nloctyp
6844         endif
6845         itk1=itype2loc(itype(k+1))
6846         itj=itype2loc(itype(j))
6847         if (l.lt.nres-1) then
6848           itl1=itype2loc(itype(l+1))
6849         else
6850           itl1=nloctyp
6851         endif
6852 C A1 kernel(j+1) A2T
6853 cd        do iii=1,2
6854 cd          write (iout,'(3f10.5,5x,3f10.5)')
6855 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6856 cd        enddo
6857         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6858      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6859      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6860 C Following matrices are needed only for 6-th order cumulants
6861         IF (wcorr6.gt.0.0d0) THEN
6862         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6863      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6864      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6865         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6866      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6867      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6868      &   ADtEAderx(1,1,1,1,1,1))
6869         lprn=.false.
6870         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6871      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6872      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6873      &   ADtEA1derx(1,1,1,1,1,1))
6874         ENDIF
6875 C End 6-th order cumulants
6876 cd        lprn=.false.
6877 cd        if (lprn) then
6878 cd        write (2,*) 'In calc_eello6'
6879 cd        do iii=1,2
6880 cd          write (2,*) 'iii=',iii
6881 cd          do kkk=1,5
6882 cd            write (2,*) 'kkk=',kkk
6883 cd            do jjj=1,2
6884 cd              write (2,'(3(2f10.5),5x)')
6885 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6886 cd            enddo
6887 cd          enddo
6888 cd        enddo
6889 cd        endif
6890         call transpose2(EUgder(1,1,k),auxmat(1,1))
6891         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6892         call transpose2(EUg(1,1,k),auxmat(1,1))
6893         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6894         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6895         do iii=1,2
6896           do kkk=1,5
6897             do lll=1,3
6898               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6899      &          EAEAderx(1,1,lll,kkk,iii,1))
6900             enddo
6901           enddo
6902         enddo
6903 C A1T kernel(i+1) A2
6904         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6905      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6906      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6907 C Following matrices are needed only for 6-th order cumulants
6908         IF (wcorr6.gt.0.0d0) THEN
6909         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6910      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6911      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6912         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6913      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6914      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6915      &   ADtEAderx(1,1,1,1,1,2))
6916         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6917      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6918      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6919      &   ADtEA1derx(1,1,1,1,1,2))
6920         ENDIF
6921 C End 6-th order cumulants
6922         call transpose2(EUgder(1,1,l),auxmat(1,1))
6923         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6924         call transpose2(EUg(1,1,l),auxmat(1,1))
6925         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6926         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6927         do iii=1,2
6928           do kkk=1,5
6929             do lll=1,3
6930               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6931      &          EAEAderx(1,1,lll,kkk,iii,2))
6932             enddo
6933           enddo
6934         enddo
6935 C AEAb1 and AEAb2
6936 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6937 C They are needed only when the fifth- or the sixth-order cumulants are
6938 C indluded.
6939         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6940         call transpose2(AEA(1,1,1),auxmat(1,1))
6941         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6942         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6943         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6944         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6945         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6946         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6947         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6948         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6949         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6950         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6951         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6952         call transpose2(AEA(1,1,2),auxmat(1,1))
6953         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6954         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6955         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6956         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6957         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6958         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6959         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6960         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6961         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6962         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6963         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6964 C Calculate the Cartesian derivatives of the vectors.
6965         do iii=1,2
6966           do kkk=1,5
6967             do lll=1,3
6968               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6969               call matvec2(auxmat(1,1),b1(1,i),
6970      &          AEAb1derx(1,lll,kkk,iii,1,1))
6971               call matvec2(auxmat(1,1),Ub2(1,i),
6972      &          AEAb2derx(1,lll,kkk,iii,1,1))
6973               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
6974      &          AEAb1derx(1,lll,kkk,iii,2,1))
6975               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6976      &          AEAb2derx(1,lll,kkk,iii,2,1))
6977               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6978               call matvec2(auxmat(1,1),b1(1,j),
6979      &          AEAb1derx(1,lll,kkk,iii,1,2))
6980               call matvec2(auxmat(1,1),Ub2(1,j),
6981      &          AEAb2derx(1,lll,kkk,iii,1,2))
6982               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
6983      &          AEAb1derx(1,lll,kkk,iii,2,2))
6984               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6985      &          AEAb2derx(1,lll,kkk,iii,2,2))
6986             enddo
6987           enddo
6988         enddo
6989         ENDIF
6990 C End vectors
6991       else
6992 C Antiparallel orientation of the two CA-CA-CA frames.
6993         if (i.gt.1) then
6994           iti=itype2loc(itype(i))
6995         else
6996           iti=nloctyp
6997         endif
6998         itk1=itype2loc(itype(k+1))
6999         itl=itype2loc(itype(l))
7000         itj=itype2loc(itype(j))
7001         if (j.lt.nres-1) then
7002           itj1=itype2loc(itype(j+1))
7003         else
7004           itj1=nloctyp
7005         endif
7006 C A2 kernel(j-1)T A1T
7007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7008      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7009      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7010 C Following matrices are needed only for 6-th order cumulants
7011         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7012      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7013         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7014      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7015      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7016         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7017      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7018      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7019      &   ADtEAderx(1,1,1,1,1,1))
7020         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7021      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7022      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7023      &   ADtEA1derx(1,1,1,1,1,1))
7024         ENDIF
7025 C End 6-th order cumulants
7026         call transpose2(EUgder(1,1,k),auxmat(1,1))
7027         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7028         call transpose2(EUg(1,1,k),auxmat(1,1))
7029         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7030         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7031         do iii=1,2
7032           do kkk=1,5
7033             do lll=1,3
7034               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7035      &          EAEAderx(1,1,lll,kkk,iii,1))
7036             enddo
7037           enddo
7038         enddo
7039 C A2T kernel(i+1)T A1
7040         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7041      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7042      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7043 C Following matrices are needed only for 6-th order cumulants
7044         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7045      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7046         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7047      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7048      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7049         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7050      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7051      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7052      &   ADtEAderx(1,1,1,1,1,2))
7053         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7054      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7055      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7056      &   ADtEA1derx(1,1,1,1,1,2))
7057         ENDIF
7058 C End 6-th order cumulants
7059         call transpose2(EUgder(1,1,j),auxmat(1,1))
7060         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7061         call transpose2(EUg(1,1,j),auxmat(1,1))
7062         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7063         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7064         do iii=1,2
7065           do kkk=1,5
7066             do lll=1,3
7067               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7068      &          EAEAderx(1,1,lll,kkk,iii,2))
7069             enddo
7070           enddo
7071         enddo
7072 C AEAb1 and AEAb2
7073 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7074 C They are needed only when the fifth- or the sixth-order cumulants are
7075 C indluded.
7076         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7077      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7078         call transpose2(AEA(1,1,1),auxmat(1,1))
7079         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7080         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7081         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7082         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7083         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7084         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7085         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7086         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7087         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7088         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7089         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7090         call transpose2(AEA(1,1,2),auxmat(1,1))
7091         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7092         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7093         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7094         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7095         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7096         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7097         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7098         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7099         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7100         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7101         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7102 C Calculate the Cartesian derivatives of the vectors.
7103         do iii=1,2
7104           do kkk=1,5
7105             do lll=1,3
7106               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7107               call matvec2(auxmat(1,1),b1(1,i),
7108      &          AEAb1derx(1,lll,kkk,iii,1,1))
7109               call matvec2(auxmat(1,1),Ub2(1,i),
7110      &          AEAb2derx(1,lll,kkk,iii,1,1))
7111               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7112      &          AEAb1derx(1,lll,kkk,iii,2,1))
7113               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7114      &          AEAb2derx(1,lll,kkk,iii,2,1))
7115               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7116               call matvec2(auxmat(1,1),b1(1,l),
7117      &          AEAb1derx(1,lll,kkk,iii,1,2))
7118               call matvec2(auxmat(1,1),Ub2(1,l),
7119      &          AEAb2derx(1,lll,kkk,iii,1,2))
7120               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7121      &          AEAb1derx(1,lll,kkk,iii,2,2))
7122               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7123      &          AEAb2derx(1,lll,kkk,iii,2,2))
7124             enddo
7125           enddo
7126         enddo
7127         ENDIF
7128 C End vectors
7129       endif
7130       return
7131       end
7132 C---------------------------------------------------------------------------
7133       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7134      &  KK,KKderg,AKA,AKAderg,AKAderx)
7135       implicit none
7136       integer nderg
7137       logical transp
7138       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7139      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7140      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7141       integer iii,kkk,lll
7142       integer jjj,mmm
7143       logical lprn
7144       common /kutas/ lprn
7145       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7146       do iii=1,nderg
7147         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7148      &    AKAderg(1,1,iii))
7149       enddo
7150 cd      if (lprn) write (2,*) 'In kernel'
7151       do kkk=1,5
7152 cd        if (lprn) write (2,*) 'kkk=',kkk
7153         do lll=1,3
7154           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7155      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7156 cd          if (lprn) then
7157 cd            write (2,*) 'lll=',lll
7158 cd            write (2,*) 'iii=1'
7159 cd            do jjj=1,2
7160 cd              write (2,'(3(2f10.5),5x)')
7161 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7162 cd            enddo
7163 cd          endif
7164           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7165      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7166 cd          if (lprn) then
7167 cd            write (2,*) 'lll=',lll
7168 cd            write (2,*) 'iii=2'
7169 cd            do jjj=1,2
7170 cd              write (2,'(3(2f10.5),5x)')
7171 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7172 cd            enddo
7173 cd          endif
7174         enddo
7175       enddo
7176       return
7177       end
7178 C---------------------------------------------------------------------------
7179       double precision function eello4(i,j,k,l,jj,kk)
7180       implicit real*8 (a-h,o-z)
7181       include 'DIMENSIONS'
7182       include 'COMMON.IOUNITS'
7183       include 'COMMON.CHAIN'
7184       include 'COMMON.DERIV'
7185       include 'COMMON.INTERACT'
7186       include 'COMMON.CONTACTS'
7187       include 'COMMON.TORSION'
7188       include 'COMMON.VAR'
7189       include 'COMMON.GEO'
7190       double precision pizda(2,2),ggg1(3),ggg2(3)
7191 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7192 cd        eello4=0.0d0
7193 cd        return
7194 cd      endif
7195 cd      print *,'eello4:',i,j,k,l,jj,kk
7196 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7197 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7198 cold      eij=facont_hb(jj,i)
7199 cold      ekl=facont_hb(kk,k)
7200 cold      ekont=eij*ekl
7201       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7202       if (calc_grad) then
7203 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7204       gcorr_loc(k-1)=gcorr_loc(k-1)
7205      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7206       if (l.eq.j+1) then
7207         gcorr_loc(l-1)=gcorr_loc(l-1)
7208      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7209       else
7210         gcorr_loc(j-1)=gcorr_loc(j-1)
7211      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7212       endif
7213       do iii=1,2
7214         do kkk=1,5
7215           do lll=1,3
7216             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7217      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7218 cd            derx(lll,kkk,iii)=0.0d0
7219           enddo
7220         enddo
7221       enddo
7222 cd      gcorr_loc(l-1)=0.0d0
7223 cd      gcorr_loc(j-1)=0.0d0
7224 cd      gcorr_loc(k-1)=0.0d0
7225 cd      eel4=1.0d0
7226 cd      write (iout,*)'Contacts have occurred for peptide groups',
7227 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7228 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7229       if (j.lt.nres-1) then
7230         j1=j+1
7231         j2=j-1
7232       else
7233         j1=j-1
7234         j2=j-2
7235       endif
7236       if (l.lt.nres-1) then
7237         l1=l+1
7238         l2=l-1
7239       else
7240         l1=l-1
7241         l2=l-2
7242       endif
7243       do ll=1,3
7244 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7245 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7246         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7247         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7248 cgrad        ghalf=0.5d0*ggg1(ll)
7249         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7250         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7251         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7252         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7253         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7254         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7255 cgrad        ghalf=0.5d0*ggg2(ll)
7256         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7257         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7258         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7259         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7260         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7261         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7262       enddo
7263 cgrad      do m=i+1,j-1
7264 cgrad        do ll=1,3
7265 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7266 cgrad        enddo
7267 cgrad      enddo
7268 cgrad      do m=k+1,l-1
7269 cgrad        do ll=1,3
7270 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7271 cgrad        enddo
7272 cgrad      enddo
7273 cgrad      do m=i+2,j2
7274 cgrad        do ll=1,3
7275 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7276 cgrad        enddo
7277 cgrad      enddo
7278 cgrad      do m=k+2,l2
7279 cgrad        do ll=1,3
7280 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7281 cgrad        enddo
7282 cgrad      enddo
7283 cd      do iii=1,nres-3
7284 cd        write (2,*) iii,gcorr_loc(iii)
7285 cd      enddo
7286       endif ! calc_grad
7287       eello4=ekont*eel4
7288 cd      write (2,*) 'ekont',ekont
7289 cd      write (iout,*) 'eello4',ekont*eel4
7290       return
7291       end
7292 C---------------------------------------------------------------------------
7293       double precision function eello5(i,j,k,l,jj,kk)
7294       implicit real*8 (a-h,o-z)
7295       include 'DIMENSIONS'
7296       include 'COMMON.IOUNITS'
7297       include 'COMMON.CHAIN'
7298       include 'COMMON.DERIV'
7299       include 'COMMON.INTERACT'
7300       include 'COMMON.CONTACTS'
7301       include 'COMMON.TORSION'
7302       include 'COMMON.VAR'
7303       include 'COMMON.GEO'
7304       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7305       double precision ggg1(3),ggg2(3)
7306 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7307 C                                                                              C
7308 C                            Parallel chains                                   C
7309 C                                                                              C
7310 C          o             o                   o             o                   C
7311 C         /l\           / \             \   / \           / \   /              C
7312 C        /   \         /   \             \ /   \         /   \ /               C
7313 C       j| o |l1       | o |              o| o |         | o |o                C
7314 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7315 C      \i/   \         /   \ /             /   \         /   \                 C
7316 C       o    k1             o                                                  C
7317 C         (I)          (II)                (III)          (IV)                 C
7318 C                                                                              C
7319 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7320 C                                                                              C
7321 C                            Antiparallel chains                               C
7322 C                                                                              C
7323 C          o             o                   o             o                   C
7324 C         /j\           / \             \   / \           / \   /              C
7325 C        /   \         /   \             \ /   \         /   \ /               C
7326 C      j1| o |l        | o |              o| o |         | o |o                C
7327 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7328 C      \i/   \         /   \ /             /   \         /   \                 C
7329 C       o     k1            o                                                  C
7330 C         (I)          (II)                (III)          (IV)                 C
7331 C                                                                              C
7332 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7333 C                                                                              C
7334 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7335 C                                                                              C
7336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7337 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7338 cd        eello5=0.0d0
7339 cd        return
7340 cd      endif
7341 cd      write (iout,*)
7342 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7343 cd     &   ' and',k,l
7344       itk=itype2loc(itype(k))
7345       itl=itype2loc(itype(l))
7346       itj=itype2loc(itype(j))
7347       eello5_1=0.0d0
7348       eello5_2=0.0d0
7349       eello5_3=0.0d0
7350       eello5_4=0.0d0
7351 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7352 cd     &   eel5_3_num,eel5_4_num)
7353       do iii=1,2
7354         do kkk=1,5
7355           do lll=1,3
7356             derx(lll,kkk,iii)=0.0d0
7357           enddo
7358         enddo
7359       enddo
7360 cd      eij=facont_hb(jj,i)
7361 cd      ekl=facont_hb(kk,k)
7362 cd      ekont=eij*ekl
7363 cd      write (iout,*)'Contacts have occurred for peptide groups',
7364 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7365 cd      goto 1111
7366 C Contribution from the graph I.
7367 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7368 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7369       call transpose2(EUg(1,1,k),auxmat(1,1))
7370       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7371       vv(1)=pizda(1,1)-pizda(2,2)
7372       vv(2)=pizda(1,2)+pizda(2,1)
7373       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7374      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7375       if (calc_grad) then
7376 C Explicit gradient in virtual-dihedral angles.
7377       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7378      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7379      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7380       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7381       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7382       vv(1)=pizda(1,1)-pizda(2,2)
7383       vv(2)=pizda(1,2)+pizda(2,1)
7384       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7385      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7386      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7387       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7388       vv(1)=pizda(1,1)-pizda(2,2)
7389       vv(2)=pizda(1,2)+pizda(2,1)
7390       if (l.eq.j+1) then
7391         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7392      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7393      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7394       else
7395         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7396      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7397      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7398       endif
7399 C Cartesian gradient
7400       do iii=1,2
7401         do kkk=1,5
7402           do lll=1,3
7403             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7404      &        pizda(1,1))
7405             vv(1)=pizda(1,1)-pizda(2,2)
7406             vv(2)=pizda(1,2)+pizda(2,1)
7407             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7408      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7409      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7410           enddo
7411         enddo
7412       enddo
7413       endif ! calc_grad
7414 c      goto 1112
7415 c1111  continue
7416 C Contribution from graph II
7417       call transpose2(EE(1,1,k),auxmat(1,1))
7418       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7419       vv(1)=pizda(1,1)+pizda(2,2)
7420       vv(2)=pizda(2,1)-pizda(1,2)
7421       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7422      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7423       if (calc_grad) then
7424 C Explicit gradient in virtual-dihedral angles.
7425       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7426      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7427       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7428       vv(1)=pizda(1,1)+pizda(2,2)
7429       vv(2)=pizda(2,1)-pizda(1,2)
7430       if (l.eq.j+1) then
7431         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7432      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7433      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7434       else
7435         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7436      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7437      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7438       endif
7439 C Cartesian gradient
7440       do iii=1,2
7441         do kkk=1,5
7442           do lll=1,3
7443             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7444      &        pizda(1,1))
7445             vv(1)=pizda(1,1)+pizda(2,2)
7446             vv(2)=pizda(2,1)-pizda(1,2)
7447             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7448      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7449      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7450           enddo
7451         enddo
7452       enddo
7453       endif ! calc_grad
7454 cd      goto 1112
7455 cd1111  continue
7456       if (l.eq.j+1) then
7457 cd        goto 1110
7458 C Parallel orientation
7459 C Contribution from graph III
7460         call transpose2(EUg(1,1,l),auxmat(1,1))
7461         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7462         vv(1)=pizda(1,1)-pizda(2,2)
7463         vv(2)=pizda(1,2)+pizda(2,1)
7464         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7465      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7466         if (calc_grad) then
7467 C Explicit gradient in virtual-dihedral angles.
7468         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7469      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7470      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7471         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7472         vv(1)=pizda(1,1)-pizda(2,2)
7473         vv(2)=pizda(1,2)+pizda(2,1)
7474         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7475      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7476      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7477         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7478         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7479         vv(1)=pizda(1,1)-pizda(2,2)
7480         vv(2)=pizda(1,2)+pizda(2,1)
7481         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7482      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7483      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7484 C Cartesian gradient
7485         do iii=1,2
7486           do kkk=1,5
7487             do lll=1,3
7488               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7489      &          pizda(1,1))
7490               vv(1)=pizda(1,1)-pizda(2,2)
7491               vv(2)=pizda(1,2)+pizda(2,1)
7492               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7493      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7494      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7495             enddo
7496           enddo
7497         enddo
7498 cd        goto 1112
7499 C Contribution from graph IV
7500 cd1110    continue
7501         call transpose2(EE(1,1,l),auxmat(1,1))
7502         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7503         vv(1)=pizda(1,1)+pizda(2,2)
7504         vv(2)=pizda(2,1)-pizda(1,2)
7505         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7506      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7507 C Explicit gradient in virtual-dihedral angles.
7508         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7509      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7510         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7511         vv(1)=pizda(1,1)+pizda(2,2)
7512         vv(2)=pizda(2,1)-pizda(1,2)
7513         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7514      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7515      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7516 C Cartesian gradient
7517         do iii=1,2
7518           do kkk=1,5
7519             do lll=1,3
7520               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7521      &          pizda(1,1))
7522               vv(1)=pizda(1,1)+pizda(2,2)
7523               vv(2)=pizda(2,1)-pizda(1,2)
7524               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7525      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7526      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7527             enddo
7528           enddo
7529         enddo
7530         endif ! calc_grad
7531       else
7532 C Antiparallel orientation
7533 C Contribution from graph III
7534 c        goto 1110
7535         call transpose2(EUg(1,1,j),auxmat(1,1))
7536         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7537         vv(1)=pizda(1,1)-pizda(2,2)
7538         vv(2)=pizda(1,2)+pizda(2,1)
7539         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7540      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7541         if (calc_grad) then
7542 C Explicit gradient in virtual-dihedral angles.
7543         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7544      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7545      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7546         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7547         vv(1)=pizda(1,1)-pizda(2,2)
7548         vv(2)=pizda(1,2)+pizda(2,1)
7549         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7550      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7551      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7552         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7553         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7554         vv(1)=pizda(1,1)-pizda(2,2)
7555         vv(2)=pizda(1,2)+pizda(2,1)
7556         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7557      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7558      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7559 C Cartesian gradient
7560         do iii=1,2
7561           do kkk=1,5
7562             do lll=1,3
7563               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7564      &          pizda(1,1))
7565               vv(1)=pizda(1,1)-pizda(2,2)
7566               vv(2)=pizda(1,2)+pizda(2,1)
7567               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7568      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7569      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7570             enddo
7571           enddo
7572         enddo
7573         endif ! calc_grad
7574 cd        goto 1112
7575 C Contribution from graph IV
7576 1110    continue
7577         call transpose2(EE(1,1,j),auxmat(1,1))
7578         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7579         vv(1)=pizda(1,1)+pizda(2,2)
7580         vv(2)=pizda(2,1)-pizda(1,2)
7581         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7582      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7583         if (calc_grad) then
7584 C Explicit gradient in virtual-dihedral angles.
7585         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7586      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7587         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7588         vv(1)=pizda(1,1)+pizda(2,2)
7589         vv(2)=pizda(2,1)-pizda(1,2)
7590         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7591      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7592      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7593 C Cartesian gradient
7594         do iii=1,2
7595           do kkk=1,5
7596             do lll=1,3
7597               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7598      &          pizda(1,1))
7599               vv(1)=pizda(1,1)+pizda(2,2)
7600               vv(2)=pizda(2,1)-pizda(1,2)
7601               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7602      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7603      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7604             enddo
7605           enddo
7606         enddo
7607         endif ! calc_grad
7608       endif
7609 1112  continue
7610       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7611 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7612 cd        write (2,*) 'ijkl',i,j,k,l
7613 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7614 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7615 cd      endif
7616 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7617 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7618 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7619 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7620       if (calc_grad) then
7621       if (j.lt.nres-1) then
7622         j1=j+1
7623         j2=j-1
7624       else
7625         j1=j-1
7626         j2=j-2
7627       endif
7628       if (l.lt.nres-1) then
7629         l1=l+1
7630         l2=l-1
7631       else
7632         l1=l-1
7633         l2=l-2
7634       endif
7635 cd      eij=1.0d0
7636 cd      ekl=1.0d0
7637 cd      ekont=1.0d0
7638 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7639 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7640 C        summed up outside the subrouine as for the other subroutines
7641 C        handling long-range interactions. The old code is commented out
7642 C        with "cgrad" to keep track of changes.
7643       do ll=1,3
7644 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7645 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7646         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7647         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7648 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7649 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7650 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7651 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7652 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7653 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7654 c     &   gradcorr5ij,
7655 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7656 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7657 cgrad        ghalf=0.5d0*ggg1(ll)
7658 cd        ghalf=0.0d0
7659         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7660         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7661         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7662         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7663         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7664         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7665 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7666 cgrad        ghalf=0.5d0*ggg2(ll)
7667 cd        ghalf=0.0d0
7668         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7669         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7670         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7671         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7672         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7673         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7674       enddo
7675       endif ! calc_grad
7676 cd      goto 1112
7677 cgrad      do m=i+1,j-1
7678 cgrad        do ll=1,3
7679 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7680 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7681 cgrad        enddo
7682 cgrad      enddo
7683 cgrad      do m=k+1,l-1
7684 cgrad        do ll=1,3
7685 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7686 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7687 cgrad        enddo
7688 cgrad      enddo
7689 c1112  continue
7690 cgrad      do m=i+2,j2
7691 cgrad        do ll=1,3
7692 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7693 cgrad        enddo
7694 cgrad      enddo
7695 cgrad      do m=k+2,l2
7696 cgrad        do ll=1,3
7697 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7698 cgrad        enddo
7699 cgrad      enddo
7700 cd      do iii=1,nres-3
7701 cd        write (2,*) iii,g_corr5_loc(iii)
7702 cd      enddo
7703       eello5=ekont*eel5
7704 cd      write (2,*) 'ekont',ekont
7705 cd      write (iout,*) 'eello5',ekont*eel5
7706       return
7707       end
7708 c--------------------------------------------------------------------------
7709       double precision function eello6(i,j,k,l,jj,kk)
7710       implicit real*8 (a-h,o-z)
7711       include 'DIMENSIONS'
7712       include 'COMMON.IOUNITS'
7713       include 'COMMON.CHAIN'
7714       include 'COMMON.DERIV'
7715       include 'COMMON.INTERACT'
7716       include 'COMMON.CONTACTS'
7717       include 'COMMON.TORSION'
7718       include 'COMMON.VAR'
7719       include 'COMMON.GEO'
7720       include 'COMMON.FFIELD'
7721       double precision ggg1(3),ggg2(3)
7722 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7723 cd        eello6=0.0d0
7724 cd        return
7725 cd      endif
7726 cd      write (iout,*)
7727 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7728 cd     &   ' and',k,l
7729       eello6_1=0.0d0
7730       eello6_2=0.0d0
7731       eello6_3=0.0d0
7732       eello6_4=0.0d0
7733       eello6_5=0.0d0
7734       eello6_6=0.0d0
7735 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7736 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7737       do iii=1,2
7738         do kkk=1,5
7739           do lll=1,3
7740             derx(lll,kkk,iii)=0.0d0
7741           enddo
7742         enddo
7743       enddo
7744 cd      eij=facont_hb(jj,i)
7745 cd      ekl=facont_hb(kk,k)
7746 cd      ekont=eij*ekl
7747 cd      eij=1.0d0
7748 cd      ekl=1.0d0
7749 cd      ekont=1.0d0
7750       if (l.eq.j+1) then
7751         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7752         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7753         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7754         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7755         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7756         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7757       else
7758         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7759         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7760         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7761         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7762         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7763           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7764         else
7765           eello6_5=0.0d0
7766         endif
7767         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7768       endif
7769 C If turn contributions are considered, they will be handled separately.
7770       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7771 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7772 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7773 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7774 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7775 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7776 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7777 cd      goto 1112
7778       if (calc_grad) then
7779       if (j.lt.nres-1) then
7780         j1=j+1
7781         j2=j-1
7782       else
7783         j1=j-1
7784         j2=j-2
7785       endif
7786       if (l.lt.nres-1) then
7787         l1=l+1
7788         l2=l-1
7789       else
7790         l1=l-1
7791         l2=l-2
7792       endif
7793       do ll=1,3
7794 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7795 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7796 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7797 cgrad        ghalf=0.5d0*ggg1(ll)
7798 cd        ghalf=0.0d0
7799         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7800         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7801         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7802         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7803         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7804         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7805         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7806         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7807 cgrad        ghalf=0.5d0*ggg2(ll)
7808 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7809 cd        ghalf=0.0d0
7810         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7811         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7812         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7813         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7814         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7815         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7816       enddo
7817       endif ! calc_grad
7818 cd      goto 1112
7819 cgrad      do m=i+1,j-1
7820 cgrad        do ll=1,3
7821 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7822 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7823 cgrad        enddo
7824 cgrad      enddo
7825 cgrad      do m=k+1,l-1
7826 cgrad        do ll=1,3
7827 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7828 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7829 cgrad        enddo
7830 cgrad      enddo
7831 cgrad1112  continue
7832 cgrad      do m=i+2,j2
7833 cgrad        do ll=1,3
7834 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7835 cgrad        enddo
7836 cgrad      enddo
7837 cgrad      do m=k+2,l2
7838 cgrad        do ll=1,3
7839 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7840 cgrad        enddo
7841 cgrad      enddo
7842 cd      do iii=1,nres-3
7843 cd        write (2,*) iii,g_corr6_loc(iii)
7844 cd      enddo
7845       eello6=ekont*eel6
7846 cd      write (2,*) 'ekont',ekont
7847 cd      write (iout,*) 'eello6',ekont*eel6
7848       return
7849       end
7850 c--------------------------------------------------------------------------
7851       double precision function eello6_graph1(i,j,k,l,imat,swap)
7852       implicit real*8 (a-h,o-z)
7853       include 'DIMENSIONS'
7854       include 'COMMON.IOUNITS'
7855       include 'COMMON.CHAIN'
7856       include 'COMMON.DERIV'
7857       include 'COMMON.INTERACT'
7858       include 'COMMON.CONTACTS'
7859       include 'COMMON.TORSION'
7860       include 'COMMON.VAR'
7861       include 'COMMON.GEO'
7862       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7863       logical swap
7864       logical lprn
7865       common /kutas/ lprn
7866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7867 C                                                                              C
7868 C      Parallel       Antiparallel                                             C
7869 C                                                                              C
7870 C          o             o                                                     C
7871 C         /l\           /j\                                                    C
7872 C        /   \         /   \                                                   C
7873 C       /| o |         | o |\                                                  C
7874 C     \ j|/k\|  /   \  |/k\|l /                                                C
7875 C      \ /   \ /     \ /   \ /                                                 C
7876 C       o     o       o     o                                                  C
7877 C       i             i                                                        C
7878 C                                                                              C
7879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7880       itk=itype2loc(itype(k))
7881       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7882       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7883       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7884       call transpose2(EUgC(1,1,k),auxmat(1,1))
7885       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7886       vv1(1)=pizda1(1,1)-pizda1(2,2)
7887       vv1(2)=pizda1(1,2)+pizda1(2,1)
7888       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7889       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7890       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7891       s5=scalar2(vv(1),Dtobr2(1,i))
7892 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7893       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7894       if (calc_grad) then
7895       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7896      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7897      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7898      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7899      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7900      & +scalar2(vv(1),Dtobr2der(1,i)))
7901       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7902       vv1(1)=pizda1(1,1)-pizda1(2,2)
7903       vv1(2)=pizda1(1,2)+pizda1(2,1)
7904       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7905       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7906       if (l.eq.j+1) then
7907         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7908      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7909      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7910      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7911      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7912       else
7913         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7914      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7915      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7916      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7917      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7918       endif
7919       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7920       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7921       vv1(1)=pizda1(1,1)-pizda1(2,2)
7922       vv1(2)=pizda1(1,2)+pizda1(2,1)
7923       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7924      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7925      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7926      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7927       do iii=1,2
7928         if (swap) then
7929           ind=3-iii
7930         else
7931           ind=iii
7932         endif
7933         do kkk=1,5
7934           do lll=1,3
7935             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7936             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7937             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7938             call transpose2(EUgC(1,1,k),auxmat(1,1))
7939             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7940      &        pizda1(1,1))
7941             vv1(1)=pizda1(1,1)-pizda1(2,2)
7942             vv1(2)=pizda1(1,2)+pizda1(2,1)
7943             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7944             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7945      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7946             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7947      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7948             s5=scalar2(vv(1),Dtobr2(1,i))
7949             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7950           enddo
7951         enddo
7952       enddo
7953       endif ! calc_grad
7954       return
7955       end
7956 c----------------------------------------------------------------------------
7957       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7958       implicit real*8 (a-h,o-z)
7959       include 'DIMENSIONS'
7960       include 'COMMON.IOUNITS'
7961       include 'COMMON.CHAIN'
7962       include 'COMMON.DERIV'
7963       include 'COMMON.INTERACT'
7964       include 'COMMON.CONTACTS'
7965       include 'COMMON.TORSION'
7966       include 'COMMON.VAR'
7967       include 'COMMON.GEO'
7968       logical swap
7969       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7970      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7971       logical lprn
7972       common /kutas/ lprn
7973 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7974 C                                                                              C
7975 C      Parallel       Antiparallel                                             C
7976 C                                                                              C
7977 C          o             o                                                     C
7978 C     \   /l\           /j\   /                                                C
7979 C      \ /   \         /   \ /                                                 C
7980 C       o| o |         | o |o                                                  C
7981 C     \ j|/k\|      \  |/k\|l                                                  C
7982 C      \ /   \       \ /   \                                                   C
7983 C       o             o                                                        C
7984 C       i             i                                                        C
7985 C                                                                              C
7986 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7987 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7988 C AL 7/4/01 s1 would occur in the sixth-order moment,
7989 C           but not in a cluster cumulant
7990 #ifdef MOMENT
7991       s1=dip(1,jj,i)*dip(1,kk,k)
7992 #endif
7993       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7994       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7995       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7996       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7997       call transpose2(EUg(1,1,k),auxmat(1,1))
7998       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7999       vv(1)=pizda(1,1)-pizda(2,2)
8000       vv(2)=pizda(1,2)+pizda(2,1)
8001       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8002 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8003 #ifdef MOMENT
8004       eello6_graph2=-(s1+s2+s3+s4)
8005 #else
8006       eello6_graph2=-(s2+s3+s4)
8007 #endif
8008 c      eello6_graph2=-s3
8009 C Derivatives in gamma(i-1)
8010       if (calc_grad) then
8011       if (i.gt.1) then
8012 #ifdef MOMENT
8013         s1=dipderg(1,jj,i)*dip(1,kk,k)
8014 #endif
8015         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8016         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8017         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8018         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8019 #ifdef MOMENT
8020         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8021 #else
8022         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8023 #endif
8024 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8025       endif
8026 C Derivatives in gamma(k-1)
8027 #ifdef MOMENT
8028       s1=dip(1,jj,i)*dipderg(1,kk,k)
8029 #endif
8030       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8031       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8032       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8033       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8034       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8035       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8036       vv(1)=pizda(1,1)-pizda(2,2)
8037       vv(2)=pizda(1,2)+pizda(2,1)
8038       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8039 #ifdef MOMENT
8040       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8041 #else
8042       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8043 #endif
8044 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8045 C Derivatives in gamma(j-1) or gamma(l-1)
8046       if (j.gt.1) then
8047 #ifdef MOMENT
8048         s1=dipderg(3,jj,i)*dip(1,kk,k)
8049 #endif
8050         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8051         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8052         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8053         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8054         vv(1)=pizda(1,1)-pizda(2,2)
8055         vv(2)=pizda(1,2)+pizda(2,1)
8056         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8057 #ifdef MOMENT
8058         if (swap) then
8059           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8060         else
8061           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8062         endif
8063 #endif
8064         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8065 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8066       endif
8067 C Derivatives in gamma(l-1) or gamma(j-1)
8068       if (l.gt.1) then
8069 #ifdef MOMENT
8070         s1=dip(1,jj,i)*dipderg(3,kk,k)
8071 #endif
8072         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8073         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8074         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8075         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8076         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8077         vv(1)=pizda(1,1)-pizda(2,2)
8078         vv(2)=pizda(1,2)+pizda(2,1)
8079         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8080 #ifdef MOMENT
8081         if (swap) then
8082           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8083         else
8084           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8085         endif
8086 #endif
8087         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8088 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8089       endif
8090 C Cartesian derivatives.
8091       if (lprn) then
8092         write (2,*) 'In eello6_graph2'
8093         do iii=1,2
8094           write (2,*) 'iii=',iii
8095           do kkk=1,5
8096             write (2,*) 'kkk=',kkk
8097             do jjj=1,2
8098               write (2,'(3(2f10.5),5x)')
8099      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8100             enddo
8101           enddo
8102         enddo
8103       endif
8104       do iii=1,2
8105         do kkk=1,5
8106           do lll=1,3
8107 #ifdef MOMENT
8108             if (iii.eq.1) then
8109               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8110             else
8111               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8112             endif
8113 #endif
8114             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8115      &        auxvec(1))
8116             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8117             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8118      &        auxvec(1))
8119             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8120             call transpose2(EUg(1,1,k),auxmat(1,1))
8121             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8122      &        pizda(1,1))
8123             vv(1)=pizda(1,1)-pizda(2,2)
8124             vv(2)=pizda(1,2)+pizda(2,1)
8125             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8126 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8127 #ifdef MOMENT
8128             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8129 #else
8130             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8131 #endif
8132             if (swap) then
8133               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8134             else
8135               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8136             endif
8137           enddo
8138         enddo
8139       enddo
8140       endif ! calc_grad
8141       return
8142       end
8143 c----------------------------------------------------------------------------
8144       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8145       implicit real*8 (a-h,o-z)
8146       include 'DIMENSIONS'
8147       include 'COMMON.IOUNITS'
8148       include 'COMMON.CHAIN'
8149       include 'COMMON.DERIV'
8150       include 'COMMON.INTERACT'
8151       include 'COMMON.CONTACTS'
8152       include 'COMMON.TORSION'
8153       include 'COMMON.VAR'
8154       include 'COMMON.GEO'
8155       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8156       logical swap
8157 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8158 C                                                                              C
8159 C      Parallel       Antiparallel                                             C
8160 C                                                                              C
8161 C          o             o                                                     C
8162 C         /l\   /   \   /j\                                                    C
8163 C        /   \ /     \ /   \                                                   C
8164 C       /| o |o       o| o |\                                                  C
8165 C       j|/k\|  /      |/k\|l /                                                C
8166 C        /   \ /       /   \ /                                                 C
8167 C       /     o       /     o                                                  C
8168 C       i             i                                                        C
8169 C                                                                              C
8170 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8171 C
8172 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8173 C           energy moment and not to the cluster cumulant.
8174       iti=itortyp(itype(i))
8175       if (j.lt.nres-1) then
8176         itj1=itype2loc(itype(j+1))
8177       else
8178         itj1=nloctyp
8179       endif
8180       itk=itype2loc(itype(k))
8181       itk1=itype2loc(itype(k+1))
8182       if (l.lt.nres-1) then
8183         itl1=itype2loc(itype(l+1))
8184       else
8185         itl1=nloctyp
8186       endif
8187 #ifdef MOMENT
8188       s1=dip(4,jj,i)*dip(4,kk,k)
8189 #endif
8190       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8191       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8192       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8193       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8194       call transpose2(EE(1,1,k),auxmat(1,1))
8195       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8196       vv(1)=pizda(1,1)+pizda(2,2)
8197       vv(2)=pizda(2,1)-pizda(1,2)
8198       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8199 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8200 cd     & "sum",-(s2+s3+s4)
8201 #ifdef MOMENT
8202       eello6_graph3=-(s1+s2+s3+s4)
8203 #else
8204       eello6_graph3=-(s2+s3+s4)
8205 #endif
8206 c      eello6_graph3=-s4
8207 C Derivatives in gamma(k-1)
8208       if (calc_grad) then
8209       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8210       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8211       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8212       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8213 C Derivatives in gamma(l-1)
8214       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8215       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8216       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8217       vv(1)=pizda(1,1)+pizda(2,2)
8218       vv(2)=pizda(2,1)-pizda(1,2)
8219       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8220       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8221 C Cartesian derivatives.
8222       do iii=1,2
8223         do kkk=1,5
8224           do lll=1,3
8225 #ifdef MOMENT
8226             if (iii.eq.1) then
8227               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8228             else
8229               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8230             endif
8231 #endif
8232             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8233      &        auxvec(1))
8234             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8235             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8236      &        auxvec(1))
8237             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8238             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8239      &        pizda(1,1))
8240             vv(1)=pizda(1,1)+pizda(2,2)
8241             vv(2)=pizda(2,1)-pizda(1,2)
8242             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8243 #ifdef MOMENT
8244             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8245 #else
8246             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8247 #endif
8248             if (swap) then
8249               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8250             else
8251               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8252             endif
8253 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8254           enddo
8255         enddo
8256       enddo
8257       endif ! calc_grad
8258       return
8259       end
8260 c----------------------------------------------------------------------------
8261       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8262       implicit real*8 (a-h,o-z)
8263       include 'DIMENSIONS'
8264       include 'COMMON.IOUNITS'
8265       include 'COMMON.CHAIN'
8266       include 'COMMON.DERIV'
8267       include 'COMMON.INTERACT'
8268       include 'COMMON.CONTACTS'
8269       include 'COMMON.TORSION'
8270       include 'COMMON.VAR'
8271       include 'COMMON.GEO'
8272       include 'COMMON.FFIELD'
8273       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8274      & auxvec1(2),auxmat1(2,2)
8275       logical swap
8276 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8277 C                                                                              C
8278 C      Parallel       Antiparallel                                             C
8279 C                                                                              C
8280 C          o             o                                                     C
8281 C         /l\   /   \   /j\                                                    C
8282 C        /   \ /     \ /   \                                                   C
8283 C       /| o |o       o| o |\                                                  C
8284 C     \ j|/k\|      \  |/k\|l                                                  C
8285 C      \ /   \       \ /   \                                                   C
8286 C       o     \       o     \                                                  C
8287 C       i             i                                                        C
8288 C                                                                              C
8289 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8290 C
8291 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8292 C           energy moment and not to the cluster cumulant.
8293 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8294       iti=itype2loc(itype(i))
8295       itj=itype2loc(itype(j))
8296       if (j.lt.nres-1) then
8297         itj1=itype2loc(itype(j+1))
8298       else
8299         itj1=nloctyp
8300       endif
8301       itk=itype2loc(itype(k))
8302       if (k.lt.nres-1) then
8303         itk1=itype2loc(itype(k+1))
8304       else
8305         itk1=nloctyp
8306       endif
8307       itl=itype2loc(itype(l))
8308       if (l.lt.nres-1) then
8309         itl1=itype2loc(itype(l+1))
8310       else
8311         itl1=nloctyp
8312       endif
8313 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8314 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8315 cd     & ' itl',itl,' itl1',itl1
8316 #ifdef MOMENT
8317       if (imat.eq.1) then
8318         s1=dip(3,jj,i)*dip(3,kk,k)
8319       else
8320         s1=dip(2,jj,j)*dip(2,kk,l)
8321       endif
8322 #endif
8323       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8324       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8325       if (j.eq.l+1) then
8326         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8327         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8328       else
8329         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8330         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8331       endif
8332       call transpose2(EUg(1,1,k),auxmat(1,1))
8333       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8334       vv(1)=pizda(1,1)-pizda(2,2)
8335       vv(2)=pizda(2,1)+pizda(1,2)
8336       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8337 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8338 #ifdef MOMENT
8339       eello6_graph4=-(s1+s2+s3+s4)
8340 #else
8341       eello6_graph4=-(s2+s3+s4)
8342 #endif
8343 C Derivatives in gamma(i-1)
8344       if (calc_grad) then
8345       if (i.gt.1) then
8346 #ifdef MOMENT
8347         if (imat.eq.1) then
8348           s1=dipderg(2,jj,i)*dip(3,kk,k)
8349         else
8350           s1=dipderg(4,jj,j)*dip(2,kk,l)
8351         endif
8352 #endif
8353         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8354         if (j.eq.l+1) then
8355           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8356           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8357         else
8358           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8359           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8360         endif
8361         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8362         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8363 cd          write (2,*) 'turn6 derivatives'
8364 #ifdef MOMENT
8365           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8366 #else
8367           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8368 #endif
8369         else
8370 #ifdef MOMENT
8371           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8372 #else
8373           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8374 #endif
8375         endif
8376       endif
8377 C Derivatives in gamma(k-1)
8378 #ifdef MOMENT
8379       if (imat.eq.1) then
8380         s1=dip(3,jj,i)*dipderg(2,kk,k)
8381       else
8382         s1=dip(2,jj,j)*dipderg(4,kk,l)
8383       endif
8384 #endif
8385       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8386       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8387       if (j.eq.l+1) then
8388         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8389         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8390       else
8391         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8392         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8393       endif
8394       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8395       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8396       vv(1)=pizda(1,1)-pizda(2,2)
8397       vv(2)=pizda(2,1)+pizda(1,2)
8398       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8399       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8400 #ifdef MOMENT
8401         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8402 #else
8403         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8404 #endif
8405       else
8406 #ifdef MOMENT
8407         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8408 #else
8409         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8410 #endif
8411       endif
8412 C Derivatives in gamma(j-1) or gamma(l-1)
8413       if (l.eq.j+1 .and. l.gt.1) then
8414         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8415         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8416         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8417         vv(1)=pizda(1,1)-pizda(2,2)
8418         vv(2)=pizda(2,1)+pizda(1,2)
8419         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8420         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8421       else if (j.gt.1) then
8422         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8423         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8424         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8425         vv(1)=pizda(1,1)-pizda(2,2)
8426         vv(2)=pizda(2,1)+pizda(1,2)
8427         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8428         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8429           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8430         else
8431           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8432         endif
8433       endif
8434 C Cartesian derivatives.
8435       do iii=1,2
8436         do kkk=1,5
8437           do lll=1,3
8438 #ifdef MOMENT
8439             if (iii.eq.1) then
8440               if (imat.eq.1) then
8441                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8442               else
8443                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8444               endif
8445             else
8446               if (imat.eq.1) then
8447                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8448               else
8449                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8450               endif
8451             endif
8452 #endif
8453             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8454      &        auxvec(1))
8455             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8456             if (j.eq.l+1) then
8457               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8458      &          b1(1,j+1),auxvec(1))
8459               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8460             else
8461               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8462      &          b1(1,l+1),auxvec(1))
8463               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8464             endif
8465             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8466      &        pizda(1,1))
8467             vv(1)=pizda(1,1)-pizda(2,2)
8468             vv(2)=pizda(2,1)+pizda(1,2)
8469             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8470             if (swap) then
8471               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8472 #ifdef MOMENT
8473                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8474      &             -(s1+s2+s4)
8475 #else
8476                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8477      &             -(s2+s4)
8478 #endif
8479                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8480               else
8481 #ifdef MOMENT
8482                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8483 #else
8484                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8485 #endif
8486                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8487               endif
8488             else
8489 #ifdef MOMENT
8490               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8491 #else
8492               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8493 #endif
8494               if (l.eq.j+1) then
8495                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8496               else
8497                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8498               endif
8499             endif
8500           enddo
8501         enddo
8502       enddo
8503       endif ! calc_grad
8504       return
8505       end
8506 c----------------------------------------------------------------------------
8507       double precision function eello_turn6(i,jj,kk)
8508       implicit real*8 (a-h,o-z)
8509       include 'DIMENSIONS'
8510       include 'COMMON.IOUNITS'
8511       include 'COMMON.CHAIN'
8512       include 'COMMON.DERIV'
8513       include 'COMMON.INTERACT'
8514       include 'COMMON.CONTACTS'
8515       include 'COMMON.TORSION'
8516       include 'COMMON.VAR'
8517       include 'COMMON.GEO'
8518       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8519      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8520      &  ggg1(3),ggg2(3)
8521       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8522      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8523 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8524 C           the respective energy moment and not to the cluster cumulant.
8525       s1=0.0d0
8526       s8=0.0d0
8527       s13=0.0d0
8528 c
8529       eello_turn6=0.0d0
8530       j=i+4
8531       k=i+1
8532       l=i+3
8533       iti=itype2loc(itype(i))
8534       itk=itype2loc(itype(k))
8535       itk1=itype2loc(itype(k+1))
8536       itl=itype2loc(itype(l))
8537       itj=itype2loc(itype(j))
8538 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8539 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8540 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8541 cd        eello6=0.0d0
8542 cd        return
8543 cd      endif
8544 cd      write (iout,*)
8545 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8546 cd     &   ' and',k,l
8547 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8548       do iii=1,2
8549         do kkk=1,5
8550           do lll=1,3
8551             derx_turn(lll,kkk,iii)=0.0d0
8552           enddo
8553         enddo
8554       enddo
8555 cd      eij=1.0d0
8556 cd      ekl=1.0d0
8557 cd      ekont=1.0d0
8558       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8559 cd      eello6_5=0.0d0
8560 cd      write (2,*) 'eello6_5',eello6_5
8561 #ifdef MOMENT
8562       call transpose2(AEA(1,1,1),auxmat(1,1))
8563       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8564       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8565       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8566 #endif
8567       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8568       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8569       s2 = scalar2(b1(1,k),vtemp1(1))
8570 #ifdef MOMENT
8571       call transpose2(AEA(1,1,2),atemp(1,1))
8572       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8573       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8574       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8575 #endif
8576       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8577       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8578       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8579 #ifdef MOMENT
8580       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8581       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8582       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8583       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8584       ss13 = scalar2(b1(1,k),vtemp4(1))
8585       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8586 #endif
8587 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8588 c      s1=0.0d0
8589 c      s2=0.0d0
8590 c      s8=0.0d0
8591 c      s12=0.0d0
8592 c      s13=0.0d0
8593       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8594 C Derivatives in gamma(i+2)
8595       if (calc_grad) then
8596       s1d =0.0d0
8597       s8d =0.0d0
8598 #ifdef MOMENT
8599       call transpose2(AEA(1,1,1),auxmatd(1,1))
8600       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8601       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8602       call transpose2(AEAderg(1,1,2),atempd(1,1))
8603       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8604       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8605 #endif
8606       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8607       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8608       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8609 c      s1d=0.0d0
8610 c      s2d=0.0d0
8611 c      s8d=0.0d0
8612 c      s12d=0.0d0
8613 c      s13d=0.0d0
8614       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8615 C Derivatives in gamma(i+3)
8616 #ifdef MOMENT
8617       call transpose2(AEA(1,1,1),auxmatd(1,1))
8618       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8619       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8620       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8621 #endif
8622       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8623       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8624       s2d = scalar2(b1(1,k),vtemp1d(1))
8625 #ifdef MOMENT
8626       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8627       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8628 #endif
8629       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8630 #ifdef MOMENT
8631       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8632       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8633       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8634 #endif
8635 c      s1d=0.0d0
8636 c      s2d=0.0d0
8637 c      s8d=0.0d0
8638 c      s12d=0.0d0
8639 c      s13d=0.0d0
8640 #ifdef MOMENT
8641       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8642      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8643 #else
8644       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8645      &               -0.5d0*ekont*(s2d+s12d)
8646 #endif
8647 C Derivatives in gamma(i+4)
8648       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8649       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8650       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8651 #ifdef MOMENT
8652       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8653       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8654       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8655 #endif
8656 c      s1d=0.0d0
8657 c      s2d=0.0d0
8658 c      s8d=0.0d0
8659 C      s12d=0.0d0
8660 c      s13d=0.0d0
8661 #ifdef MOMENT
8662       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8663 #else
8664       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8665 #endif
8666 C Derivatives in gamma(i+5)
8667 #ifdef MOMENT
8668       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8669       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8670       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8671 #endif
8672       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8673       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8674       s2d = scalar2(b1(1,k),vtemp1d(1))
8675 #ifdef MOMENT
8676       call transpose2(AEA(1,1,2),atempd(1,1))
8677       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8678       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8679 #endif
8680       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8681       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8682 #ifdef MOMENT
8683       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8684       ss13d = scalar2(b1(1,k),vtemp4d(1))
8685       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8686 #endif
8687 c      s1d=0.0d0
8688 c      s2d=0.0d0
8689 c      s8d=0.0d0
8690 c      s12d=0.0d0
8691 c      s13d=0.0d0
8692 #ifdef MOMENT
8693       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8694      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8695 #else
8696       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8697      &               -0.5d0*ekont*(s2d+s12d)
8698 #endif
8699 C Cartesian derivatives
8700       do iii=1,2
8701         do kkk=1,5
8702           do lll=1,3
8703 #ifdef MOMENT
8704             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8705             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8706             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8707 #endif
8708             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8709             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8710      &          vtemp1d(1))
8711             s2d = scalar2(b1(1,k),vtemp1d(1))
8712 #ifdef MOMENT
8713             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8714             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8715             s8d = -(atempd(1,1)+atempd(2,2))*
8716      &           scalar2(cc(1,1,l),vtemp2(1))
8717 #endif
8718             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8719      &           auxmatd(1,1))
8720             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8721             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8722 c      s1d=0.0d0
8723 c      s2d=0.0d0
8724 c      s8d=0.0d0
8725 c      s12d=0.0d0
8726 c      s13d=0.0d0
8727 #ifdef MOMENT
8728             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8729      &        - 0.5d0*(s1d+s2d)
8730 #else
8731             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8732      &        - 0.5d0*s2d
8733 #endif
8734 #ifdef MOMENT
8735             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8736      &        - 0.5d0*(s8d+s12d)
8737 #else
8738             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8739      &        - 0.5d0*s12d
8740 #endif
8741           enddo
8742         enddo
8743       enddo
8744 #ifdef MOMENT
8745       do kkk=1,5
8746         do lll=1,3
8747           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8748      &      achuj_tempd(1,1))
8749           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8750           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8751           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8752           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8753           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8754      &      vtemp4d(1))
8755           ss13d = scalar2(b1(1,k),vtemp4d(1))
8756           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8757           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8758         enddo
8759       enddo
8760 #endif
8761 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8762 cd     &  16*eel_turn6_num
8763 cd      goto 1112
8764       if (j.lt.nres-1) then
8765         j1=j+1
8766         j2=j-1
8767       else
8768         j1=j-1
8769         j2=j-2
8770       endif
8771       if (l.lt.nres-1) then
8772         l1=l+1
8773         l2=l-1
8774       else
8775         l1=l-1
8776         l2=l-2
8777       endif
8778       do ll=1,3
8779 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8780 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8781 cgrad        ghalf=0.5d0*ggg1(ll)
8782 cd        ghalf=0.0d0
8783         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8784         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8785         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8786      &    +ekont*derx_turn(ll,2,1)
8787         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8788         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8789      &    +ekont*derx_turn(ll,4,1)
8790         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8791         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8792         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8793 cgrad        ghalf=0.5d0*ggg2(ll)
8794 cd        ghalf=0.0d0
8795         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8796      &    +ekont*derx_turn(ll,2,2)
8797         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8798         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8799      &    +ekont*derx_turn(ll,4,2)
8800         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8801         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8802         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8803       enddo
8804 cd      goto 1112
8805 cgrad      do m=i+1,j-1
8806 cgrad        do ll=1,3
8807 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8808 cgrad        enddo
8809 cgrad      enddo
8810 cgrad      do m=k+1,l-1
8811 cgrad        do ll=1,3
8812 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8813 cgrad        enddo
8814 cgrad      enddo
8815 cgrad1112  continue
8816 cgrad      do m=i+2,j2
8817 cgrad        do ll=1,3
8818 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8819 cgrad        enddo
8820 cgrad      enddo
8821 cgrad      do m=k+2,l2
8822 cgrad        do ll=1,3
8823 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8824 cgrad        enddo
8825 cgrad      enddo
8826 cd      do iii=1,nres-3
8827 cd        write (2,*) iii,g_corr6_loc(iii)
8828 cd      enddo
8829       endif ! calc_grad
8830       eello_turn6=ekont*eel_turn6
8831 cd      write (2,*) 'ekont',ekont
8832 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8833       return
8834       end
8835
8836 crc-------------------------------------------------
8837 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8838       subroutine Eliptransfer(eliptran)
8839       implicit real*8 (a-h,o-z)
8840       include 'DIMENSIONS'
8841       include 'COMMON.GEO'
8842       include 'COMMON.VAR'
8843       include 'COMMON.LOCAL'
8844       include 'COMMON.CHAIN'
8845       include 'COMMON.DERIV'
8846       include 'COMMON.INTERACT'
8847       include 'COMMON.IOUNITS'
8848       include 'COMMON.CALC'
8849       include 'COMMON.CONTROL'
8850       include 'COMMON.SPLITELE'
8851       include 'COMMON.SBRIDGE'
8852 C this is done by Adasko
8853 C      print *,"wchodze"
8854 C structure of box:
8855 C      water
8856 C--bordliptop-- buffore starts
8857 C--bufliptop--- here true lipid starts
8858 C      lipid
8859 C--buflipbot--- lipid ends buffore starts
8860 C--bordlipbot--buffore ends
8861       eliptran=0.0
8862       do i=1,nres
8863 C       do i=1,1
8864         if (itype(i).eq.ntyp1) cycle
8865
8866         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8867         if (positi.le.0) positi=positi+boxzsize
8868 C        print *,i
8869 C first for peptide groups
8870 c for each residue check if it is in lipid or lipid water border area
8871        if ((positi.gt.bordlipbot)
8872      &.and.(positi.lt.bordliptop)) then
8873 C the energy transfer exist
8874         if (positi.lt.buflipbot) then
8875 C what fraction I am in
8876          fracinbuf=1.0d0-
8877      &        ((positi-bordlipbot)/lipbufthick)
8878 C lipbufthick is thickenes of lipid buffore
8879          sslip=sscalelip(fracinbuf)
8880          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8881          eliptran=eliptran+sslip*pepliptran
8882          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8883          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8884 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8885         elseif (positi.gt.bufliptop) then
8886          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8887          sslip=sscalelip(fracinbuf)
8888          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8889          eliptran=eliptran+sslip*pepliptran
8890          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8891          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8892 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8893 C          print *, "doing sscalefor top part"
8894 C         print *,i,sslip,fracinbuf,ssgradlip
8895         else
8896          eliptran=eliptran+pepliptran
8897 C         print *,"I am in true lipid"
8898         endif
8899 C       else
8900 C       eliptran=elpitran+0.0 ! I am in water
8901        endif
8902        enddo
8903 C       print *, "nic nie bylo w lipidzie?"
8904 C now multiply all by the peptide group transfer factor
8905 C       eliptran=eliptran*pepliptran
8906 C now the same for side chains
8907 CV       do i=1,1
8908        do i=1,nres
8909         if (itype(i).eq.ntyp1) cycle
8910         positi=(mod(c(3,i+nres),boxzsize))
8911         if (positi.le.0) positi=positi+boxzsize
8912 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8913 c for each residue check if it is in lipid or lipid water border area
8914 C       respos=mod(c(3,i+nres),boxzsize)
8915 C       print *,positi,bordlipbot,buflipbot
8916        if ((positi.gt.bordlipbot)
8917      & .and.(positi.lt.bordliptop)) then
8918 C the energy transfer exist
8919         if (positi.lt.buflipbot) then
8920          fracinbuf=1.0d0-
8921      &     ((positi-bordlipbot)/lipbufthick)
8922 C lipbufthick is thickenes of lipid buffore
8923          sslip=sscalelip(fracinbuf)
8924          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8925          eliptran=eliptran+sslip*liptranene(itype(i))
8926          gliptranx(3,i)=gliptranx(3,i)
8927      &+ssgradlip*liptranene(itype(i))
8928          gliptranc(3,i-1)= gliptranc(3,i-1)
8929      &+ssgradlip*liptranene(itype(i))
8930 C         print *,"doing sccale for lower part"
8931         elseif (positi.gt.bufliptop) then
8932          fracinbuf=1.0d0-
8933      &((bordliptop-positi)/lipbufthick)
8934          sslip=sscalelip(fracinbuf)
8935          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8936          eliptran=eliptran+sslip*liptranene(itype(i))
8937          gliptranx(3,i)=gliptranx(3,i)
8938      &+ssgradlip*liptranene(itype(i))
8939          gliptranc(3,i-1)= gliptranc(3,i-1)
8940      &+ssgradlip*liptranene(itype(i))
8941 C          print *, "doing sscalefor top part",sslip,fracinbuf
8942         else
8943          eliptran=eliptran+liptranene(itype(i))
8944 C         print *,"I am in true lipid"
8945         endif
8946         endif ! if in lipid or buffor
8947 C       else
8948 C       eliptran=elpitran+0.0 ! I am in water
8949        enddo
8950        return
8951        end
8952
8953
8954 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8955
8956       SUBROUTINE MATVEC2(A1,V1,V2)
8957       implicit real*8 (a-h,o-z)
8958       include 'DIMENSIONS'
8959       DIMENSION A1(2,2),V1(2),V2(2)
8960 c      DO 1 I=1,2
8961 c        VI=0.0
8962 c        DO 3 K=1,2
8963 c    3     VI=VI+A1(I,K)*V1(K)
8964 c        Vaux(I)=VI
8965 c    1 CONTINUE
8966
8967       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8968       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8969
8970       v2(1)=vaux1
8971       v2(2)=vaux2
8972       END
8973 C---------------------------------------
8974       SUBROUTINE MATMAT2(A1,A2,A3)
8975       implicit real*8 (a-h,o-z)
8976       include 'DIMENSIONS'
8977       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8978 c      DIMENSION AI3(2,2)
8979 c        DO  J=1,2
8980 c          A3IJ=0.0
8981 c          DO K=1,2
8982 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8983 c          enddo
8984 c          A3(I,J)=A3IJ
8985 c       enddo
8986 c      enddo
8987
8988       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8989       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8990       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8991       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8992
8993       A3(1,1)=AI3_11
8994       A3(2,1)=AI3_21
8995       A3(1,2)=AI3_12
8996       A3(2,2)=AI3_22
8997       END
8998
8999 c-------------------------------------------------------------------------
9000       double precision function scalar2(u,v)
9001       implicit none
9002       double precision u(2),v(2)
9003       double precision sc
9004       integer i
9005       scalar2=u(1)*v(1)+u(2)*v(2)
9006       return
9007       end
9008
9009 C-----------------------------------------------------------------------------
9010
9011       subroutine transpose2(a,at)
9012       implicit none
9013       double precision a(2,2),at(2,2)
9014       at(1,1)=a(1,1)
9015       at(1,2)=a(2,1)
9016       at(2,1)=a(1,2)
9017       at(2,2)=a(2,2)
9018       return
9019       end
9020 c--------------------------------------------------------------------------
9021       subroutine transpose(n,a,at)
9022       implicit none
9023       integer n,i,j
9024       double precision a(n,n),at(n,n)
9025       do i=1,n
9026         do j=1,n
9027           at(j,i)=a(i,j)
9028         enddo
9029       enddo
9030       return
9031       end
9032 C---------------------------------------------------------------------------
9033       subroutine prodmat3(a1,a2,kk,transp,prod)
9034       implicit none
9035       integer i,j
9036       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9037       logical transp
9038 crc      double precision auxmat(2,2),prod_(2,2)
9039
9040       if (transp) then
9041 crc        call transpose2(kk(1,1),auxmat(1,1))
9042 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9043 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9044
9045            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9046      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9047            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9048      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9049            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9050      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9051            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9052      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9053
9054       else
9055 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9056 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9057
9058            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9059      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9060            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9061      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9062            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9063      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9064            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9065      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9066
9067       endif
9068 c      call transpose2(a2(1,1),a2t(1,1))
9069
9070 crc      print *,transp
9071 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9072 crc      print *,((prod(i,j),i=1,2),j=1,2)
9073
9074       return
9075       end
9076 C-----------------------------------------------------------------------------
9077       double precision function scalar(u,v)
9078       implicit none
9079       double precision u(3),v(3)
9080       double precision sc
9081       integer i
9082       sc=0.0d0
9083       do i=1,3
9084         sc=sc+u(i)*v(i)
9085       enddo
9086       scalar=sc
9087       return
9088       end
9089 C-----------------------------------------------------------------------
9090       double precision function sscale(r)
9091       double precision r,gamm
9092       include "COMMON.SPLITELE"
9093       if(r.lt.r_cut-rlamb) then
9094         sscale=1.0d0
9095       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9096         gamm=(r-(r_cut-rlamb))/rlamb
9097         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9098       else
9099         sscale=0d0
9100       endif
9101       return
9102       end
9103 C-----------------------------------------------------------------------
9104 C-----------------------------------------------------------------------
9105       double precision function sscagrad(r)
9106       double precision r,gamm
9107       include "COMMON.SPLITELE"
9108       if(r.lt.r_cut-rlamb) then
9109         sscagrad=0.0d0
9110       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9111         gamm=(r-(r_cut-rlamb))/rlamb
9112         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9113       else
9114         sscagrad=0.0d0
9115       endif
9116       return
9117       end
9118 C-----------------------------------------------------------------------
9119 C-----------------------------------------------------------------------
9120       double precision function sscalelip(r)
9121       double precision r,gamm
9122       include "COMMON.SPLITELE"
9123 C      if(r.lt.r_cut-rlamb) then
9124 C        sscale=1.0d0
9125 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9126 C        gamm=(r-(r_cut-rlamb))/rlamb
9127         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9128 C      else
9129 C        sscale=0d0
9130 C      endif
9131       return
9132       end
9133 C-----------------------------------------------------------------------
9134       double precision function sscagradlip(r)
9135       double precision r,gamm
9136       include "COMMON.SPLITELE"
9137 C     if(r.lt.r_cut-rlamb) then
9138 C        sscagrad=0.0d0
9139 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9140 C        gamm=(r-(r_cut-rlamb))/rlamb
9141         sscagradlip=r*(6*r-6.0d0)
9142 C      else
9143 C        sscagrad=0.0d0
9144 C      endif
9145       return
9146       end
9147
9148 C-----------------------------------------------------------------------
9149        subroutine set_shield_fac
9150       implicit real*8 (a-h,o-z)
9151       include 'DIMENSIONS'
9152       include 'COMMON.CHAIN'
9153       include 'COMMON.DERIV'
9154       include 'COMMON.IOUNITS'
9155       include 'COMMON.SHIELD'
9156       include 'COMMON.INTERACT'
9157 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9158       double precision div77_81/0.974996043d0/,
9159      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9160
9161 C the vector between center of side_chain and peptide group
9162        double precision pep_side(3),long,side_calf(3),
9163      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9164      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9165 C the line belowe needs to be changed for FGPROC>1
9166       do i=1,nres-1
9167       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9168       ishield_list(i)=0
9169 Cif there two consequtive dummy atoms there is no peptide group between them
9170 C the line below has to be changed for FGPROC>1
9171       VolumeTotal=0.0
9172       do k=1,nres
9173        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9174        dist_pep_side=0.0
9175        dist_side_calf=0.0
9176        do j=1,3
9177 C first lets set vector conecting the ithe side-chain with kth side-chain
9178       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9179 C      pep_side(j)=2.0d0
9180 C and vector conecting the side-chain with its proper calfa
9181       side_calf(j)=c(j,k+nres)-c(j,k)
9182 C      side_calf(j)=2.0d0
9183       pept_group(j)=c(j,i)-c(j,i+1)
9184 C lets have their lenght
9185       dist_pep_side=pep_side(j)**2+dist_pep_side
9186       dist_side_calf=dist_side_calf+side_calf(j)**2
9187       dist_pept_group=dist_pept_group+pept_group(j)**2
9188       enddo
9189        dist_pep_side=dsqrt(dist_pep_side)
9190        dist_pept_group=dsqrt(dist_pept_group)
9191        dist_side_calf=dsqrt(dist_side_calf)
9192       do j=1,3
9193         pep_side_norm(j)=pep_side(j)/dist_pep_side
9194         side_calf_norm(j)=dist_side_calf
9195       enddo
9196 C now sscale fraction
9197        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9198 C       print *,buff_shield,"buff"
9199 C now sscale
9200         if (sh_frac_dist.le.0.0) cycle
9201 C If we reach here it means that this side chain reaches the shielding sphere
9202 C Lets add him to the list for gradient
9203         ishield_list(i)=ishield_list(i)+1
9204 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9205 C this list is essential otherwise problem would be O3
9206         shield_list(ishield_list(i),i)=k
9207 C Lets have the sscale value
9208         if (sh_frac_dist.gt.1.0) then
9209          scale_fac_dist=1.0d0
9210          do j=1,3
9211          sh_frac_dist_grad(j)=0.0d0
9212          enddo
9213         else
9214          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9215      &                   *(2.0*sh_frac_dist-3.0d0)
9216          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9217      &                  /dist_pep_side/buff_shield*0.5
9218 C remember for the final gradient multiply sh_frac_dist_grad(j)
9219 C for side_chain by factor -2 !
9220          do j=1,3
9221          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9222 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9223 C     &                    sh_frac_dist_grad(j)
9224          enddo
9225         endif
9226 C        if ((i.eq.3).and.(k.eq.2)) then
9227 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9228 C     & ,"TU"
9229 C        endif
9230
9231 C this is what is now we have the distance scaling now volume...
9232       short=short_r_sidechain(itype(k))
9233       long=long_r_sidechain(itype(k))
9234       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9235 C now costhet_grad
9236 C       costhet=0.0d0
9237        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9238 C       costhet_fac=0.0d0
9239        do j=1,3
9240          costhet_grad(j)=costhet_fac*pep_side(j)
9241        enddo
9242 C remember for the final gradient multiply costhet_grad(j)
9243 C for side_chain by factor -2 !
9244 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9245 C pep_side0pept_group is vector multiplication
9246       pep_side0pept_group=0.0
9247       do j=1,3
9248       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9249       enddo
9250       cosalfa=(pep_side0pept_group/
9251      & (dist_pep_side*dist_side_calf))
9252       fac_alfa_sin=1.0-cosalfa**2
9253       fac_alfa_sin=dsqrt(fac_alfa_sin)
9254       rkprim=fac_alfa_sin*(long-short)+short
9255 C now costhet_grad
9256        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9257        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9258
9259        do j=1,3
9260          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9261      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9262      &*(long-short)/fac_alfa_sin*cosalfa/
9263      &((dist_pep_side*dist_side_calf))*
9264      &((side_calf(j))-cosalfa*
9265      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9266
9267         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9268      &*(long-short)/fac_alfa_sin*cosalfa
9269      &/((dist_pep_side*dist_side_calf))*
9270      &(pep_side(j)-
9271      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9272        enddo
9273
9274       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9275      &                    /VSolvSphere_div
9276      &                    *wshield
9277 C now the gradient...
9278 C grad_shield is gradient of Calfa for peptide groups
9279 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9280 C     &               costhet,cosphi
9281 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9282 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9283       do j=1,3
9284       grad_shield(j,i)=grad_shield(j,i)
9285 C gradient po skalowaniu
9286      &                +(sh_frac_dist_grad(j)
9287 C  gradient po costhet
9288      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9289      &-scale_fac_dist*(cosphi_grad_long(j))
9290      &/(1.0-cosphi) )*div77_81
9291      &*VofOverlap
9292 C grad_shield_side is Cbeta sidechain gradient
9293       grad_shield_side(j,ishield_list(i),i)=
9294      &        (sh_frac_dist_grad(j)*(-2.0d0)
9295      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9296      &       +scale_fac_dist*(cosphi_grad_long(j))
9297      &        *2.0d0/(1.0-cosphi))
9298      &        *div77_81*VofOverlap
9299
9300        grad_shield_loc(j,ishield_list(i),i)=
9301      &   scale_fac_dist*cosphi_grad_loc(j)
9302      &        *2.0d0/(1.0-cosphi)
9303      &        *div77_81*VofOverlap
9304       enddo
9305       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9306       enddo
9307       fac_shield(i)=VolumeTotal*div77_81+div4_81
9308 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9309       enddo
9310       return
9311       end
9312 C--------------------------------------------------------------------------
9313 C first for shielding is setting of function of side-chains
9314        subroutine set_shield_fac2
9315       implicit real*8 (a-h,o-z)
9316       include 'DIMENSIONS'
9317       include 'COMMON.CHAIN'
9318       include 'COMMON.DERIV'
9319       include 'COMMON.IOUNITS'
9320       include 'COMMON.SHIELD'
9321       include 'COMMON.INTERACT'
9322 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9323       double precision div77_81/0.974996043d0/,
9324      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9325
9326 C the vector between center of side_chain and peptide group
9327        double precision pep_side(3),long,side_calf(3),
9328      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9329      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9330 C the line belowe needs to be changed for FGPROC>1
9331       do i=1,nres-1
9332       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9333       ishield_list(i)=0
9334 Cif there two consequtive dummy atoms there is no peptide group between them
9335 C the line below has to be changed for FGPROC>1
9336       VolumeTotal=0.0
9337       do k=1,nres
9338        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9339        dist_pep_side=0.0
9340        dist_side_calf=0.0
9341        do j=1,3
9342 C first lets set vector conecting the ithe side-chain with kth side-chain
9343       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9344 C      pep_side(j)=2.0d0
9345 C and vector conecting the side-chain with its proper calfa
9346       side_calf(j)=c(j,k+nres)-c(j,k)
9347 C      side_calf(j)=2.0d0
9348       pept_group(j)=c(j,i)-c(j,i+1)
9349 C lets have their lenght
9350       dist_pep_side=pep_side(j)**2+dist_pep_side
9351       dist_side_calf=dist_side_calf+side_calf(j)**2
9352       dist_pept_group=dist_pept_group+pept_group(j)**2
9353       enddo
9354        dist_pep_side=dsqrt(dist_pep_side)
9355        dist_pept_group=dsqrt(dist_pept_group)
9356        dist_side_calf=dsqrt(dist_side_calf)
9357       do j=1,3
9358         pep_side_norm(j)=pep_side(j)/dist_pep_side
9359         side_calf_norm(j)=dist_side_calf
9360       enddo
9361 C now sscale fraction
9362        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9363 C       print *,buff_shield,"buff"
9364 C now sscale
9365         if (sh_frac_dist.le.0.0) cycle
9366 C If we reach here it means that this side chain reaches the shielding sphere
9367 C Lets add him to the list for gradient
9368         ishield_list(i)=ishield_list(i)+1
9369 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9370 C this list is essential otherwise problem would be O3
9371         shield_list(ishield_list(i),i)=k
9372 C Lets have the sscale value
9373         if (sh_frac_dist.gt.1.0) then
9374          scale_fac_dist=1.0d0
9375          do j=1,3
9376          sh_frac_dist_grad(j)=0.0d0
9377          enddo
9378         else
9379          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9380      &                   *(2.0d0*sh_frac_dist-3.0d0)
9381          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9382      &                  /dist_pep_side/buff_shield*0.5d0
9383 C remember for the final gradient multiply sh_frac_dist_grad(j)
9384 C for side_chain by factor -2 !
9385          do j=1,3
9386          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9387 C         sh_frac_dist_grad(j)=0.0d0
9388 C         scale_fac_dist=1.0d0
9389 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9390 C     &                    sh_frac_dist_grad(j)
9391          enddo
9392         endif
9393 C this is what is now we have the distance scaling now volume...
9394       short=short_r_sidechain(itype(k))
9395       long=long_r_sidechain(itype(k))
9396       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9397       sinthet=short/dist_pep_side*costhet
9398 C now costhet_grad
9399 C       costhet=0.6d0
9400 C       sinthet=0.8
9401        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9402 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9403 C     &             -short/dist_pep_side**2/costhet)
9404 C       costhet_fac=0.0d0
9405        do j=1,3
9406          costhet_grad(j)=costhet_fac*pep_side(j)
9407        enddo
9408 C remember for the final gradient multiply costhet_grad(j)
9409 C for side_chain by factor -2 !
9410 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9411 C pep_side0pept_group is vector multiplication
9412       pep_side0pept_group=0.0d0
9413       do j=1,3
9414       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9415       enddo
9416       cosalfa=(pep_side0pept_group/
9417      & (dist_pep_side*dist_side_calf))
9418       fac_alfa_sin=1.0d0-cosalfa**2
9419       fac_alfa_sin=dsqrt(fac_alfa_sin)
9420       rkprim=fac_alfa_sin*(long-short)+short
9421 C      rkprim=short
9422
9423 C now costhet_grad
9424        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9425 C       cosphi=0.6
9426        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9427        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9428      &      dist_pep_side**2)
9429 C       sinphi=0.8
9430        do j=1,3
9431          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9432      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9433      &*(long-short)/fac_alfa_sin*cosalfa/
9434      &((dist_pep_side*dist_side_calf))*
9435      &((side_calf(j))-cosalfa*
9436      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9437 C       cosphi_grad_long(j)=0.0d0
9438         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9439      &*(long-short)/fac_alfa_sin*cosalfa
9440      &/((dist_pep_side*dist_side_calf))*
9441      &(pep_side(j)-
9442      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9443 C       cosphi_grad_loc(j)=0.0d0
9444        enddo
9445 C      print *,sinphi,sinthet
9446       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9447      &                    /VSolvSphere_div
9448 C     &                    *wshield
9449 C now the gradient...
9450       do j=1,3
9451       grad_shield(j,i)=grad_shield(j,i)
9452 C gradient po skalowaniu
9453      &                +(sh_frac_dist_grad(j)*VofOverlap
9454 C  gradient po costhet
9455      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9456      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9457      &       sinphi/sinthet*costhet*costhet_grad(j)
9458      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9459      & )*wshield
9460 C grad_shield_side is Cbeta sidechain gradient
9461       grad_shield_side(j,ishield_list(i),i)=
9462      &        (sh_frac_dist_grad(j)*(-2.0d0)
9463      &        *VofOverlap
9464      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9465      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9466      &       sinphi/sinthet*costhet*costhet_grad(j)
9467      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9468      &       )*wshield
9469
9470        grad_shield_loc(j,ishield_list(i),i)=
9471      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9472      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9473      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9474      &        ))
9475      &        *wshield
9476       enddo
9477       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9478       enddo
9479       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9480 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9481 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9482       enddo
9483       return
9484       end
9485 C--------------------------------------------------------------------------
9486       double precision function tschebyshev(m,n,x,y)
9487       implicit none
9488       include "DIMENSIONS"
9489       integer i,m,n
9490       double precision x(n),y,yy(0:maxvar),aux
9491 c Tschebyshev polynomial. Note that the first term is omitted
9492 c m=0: the constant term is included
9493 c m=1: the constant term is not included
9494       yy(0)=1.0d0
9495       yy(1)=y
9496       do i=2,n
9497         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9498       enddo
9499       aux=0.0d0
9500       do i=m,n
9501         aux=aux+x(i)*yy(i)
9502       enddo
9503       tschebyshev=aux
9504       return
9505       end
9506 C--------------------------------------------------------------------------
9507       double precision function gradtschebyshev(m,n,x,y)
9508       implicit none
9509       include "DIMENSIONS"
9510       integer i,m,n
9511       double precision x(n+1),y,yy(0:maxvar),aux
9512 c Tschebyshev polynomial. Note that the first term is omitted
9513 c m=0: the constant term is included
9514 c m=1: the constant term is not included
9515       yy(0)=1.0d0
9516       yy(1)=2.0d0*y
9517       do i=2,n
9518         yy(i)=2*y*yy(i-1)-yy(i-2)
9519       enddo
9520       aux=0.0d0
9521       do i=m,n
9522         aux=aux+x(i+1)*yy(i)*(i+1)
9523 C        print *, x(i+1),yy(i),i
9524       enddo
9525       gradtschebyshev=aux
9526       return
9527       end
9528