source/wham/src-HCD/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       include 'COMMON.SAXS'
  24       double precision fact(6)
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C      write(iout,*) 'po elektostatyce'
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   106 continue
  52       call vec_and_deriv
  53       if (shield_mode.eq.1) then
  54        call set_shield_fac
  55       else if  (shield_mode.eq.2) then
  56        call set_shield_fac2
  57       endif
  58       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  59 C            write(iout,*) 'po eelec'
  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       if (wsccor.gt.0.0d0) then
 129         call eback_sc_corr(esccor)
 130       else
 131         esccor=0.0d0
 132       endif
 133
 134       if (wliptran.gt.0) then
 135         call Eliptransfer(eliptran)
 136       else
 137         eliptran=0.0d0
 138       endif
 139 #ifdef FOURBODY
 140 C
 141 C 12/1/95 Multi-body terms
 142 C
 143       n_corr=0
 144       n_corr1=0
 145       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 146      &    .or. wturn6.gt.0.0d0) then
 147 c         write(iout,*)"calling multibody_eello"
 148          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 149 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 150 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 151       else
 152          ecorr=0.0d0
 153          ecorr5=0.0d0
 154          ecorr6=0.0d0
 155          eturn6=0.0d0
 156       endif
 157       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 158 c         write (iout,*) "Calling multibody_hbond"
 159          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 160       endif
 161 #endif
 162 c      write (iout,*) "nsaxs",nsaxs
 163 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 164       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 165         call e_saxs(Esaxs_constr)
 166 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 167       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 168         call e_saxsC(Esaxs_constr)
 169 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 170       else
 171         Esaxs_constr = 0.0d0
 172       endif
 173
 174 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 175       if (constr_homology.ge.1) then
 176         call e_modeller(ehomology_constr)
 177       else
 178         ehomology_constr=0.0d0
 179       endif
 180
 181 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 182 #ifdef DFA
 183 C     BARTEK for dfa test!
 184       edfadis=0.0d0
 185       if (wdfa_dist.gt.0) call edfad(edfadis)
 186 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 187       edfator=0.0d0
 188       if (wdfa_tor.gt.0) call edfat(edfator)
 189 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 190       edfanei=0.0d0
 191       if (wdfa_nei.gt.0) call edfan(edfanei)
 192 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 193       edfabet=0.0d0
 194       if (wdfa_beta.gt.0) call edfab(edfabet)
 195 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 196 #else
 197       edfadis=0.0d0
 198       edfator=0.0d0
 199       edfanei=0.0d0
 200       edfabet=0.0d0
 201 #endif
 202 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 203 #ifdef SPLITELE
 204       if (shield_mode.gt.0) then
 205       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 206      & +welec*fact(1)*ees
 207      & +fact(1)*wvdwpp*evdw1
 208      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 209      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 210      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 211      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 212      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 213      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 214      & +wliptran*eliptran*esaxs_constr
 215      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 216      & +wdfa_beta*edfabet
 217       else
 218       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 219      & +wvdwpp*evdw1
 220      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 221      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 222      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 223      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 224      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 225      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 226      & +wliptran*eliptran+wsaxs*esaxs_constr
 227      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 228      & +wdfa_beta*edfabet
 229       endif
 230 #else
 231       if (shield_mode.gt.0) then
 232       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 233      & +welec*fact(1)*(ees+evdw1)
 234      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 235      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 236      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 237      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 238      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 239      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 240      & +wliptran*eliptran+wsaxs*esaxs_constr
 241      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 242      & +wdfa_beta*edfabet
 243       else
 244       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 245      & +welec*fact(1)*(ees+evdw1)
 246      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 247      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 248      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 249      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 250      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 251      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 252      & +wliptran*eliptran+wsaxs*esaxs_constr
 253      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 254      & +wdfa_beta*edfabet
 255       endif
 256 #endif
 257       energia(0)=etot
 258       energia(1)=evdw
 259 #ifdef SCP14
 260       energia(2)=evdw2-evdw2_14
 261       energia(17)=evdw2_14
 262 #else
 263       energia(2)=evdw2
 264       energia(17)=0.0d0
 265 #endif
 266 #ifdef SPLITELE
 267       energia(3)=ees
 268       energia(16)=evdw1
 269 #else
 270       energia(3)=ees+evdw1
 271       energia(16)=0.0d0
 272 #endif
 273       energia(4)=ecorr
 274       energia(5)=ecorr5
 275       energia(6)=ecorr6
 276       energia(7)=eel_loc
 277       energia(8)=eello_turn3
 278       energia(9)=eello_turn4
 279       energia(10)=eturn6
 280       energia(11)=ebe
 281       energia(12)=escloc
 282       energia(13)=etors
 283       energia(14)=etors_d
 284       energia(15)=ehpb
 285       energia(18)=estr
 286       energia(19)=esccor
 287       energia(20)=edihcnstr
 288       energia(21)=evdw_t
 289       energia(22)=eliptran
 290       energia(24)=ethetacnstr
 291       energia(26)=esaxs_constr
 292       energia(27)=ehomology_constr
 293       energia(28)=edfadis
 294       energia(29)=edfator
 295       energia(30)=edfanei
 296       energia(31)=edfabet
 297 c detecting NaNQ
 298 #ifdef ISNAN
 299 #ifdef AIX
 300       if (isnan(etot).ne.0) energia(0)=1.0d+99
 301 #else
 302       if (isnan(etot)) energia(0)=1.0d+99
 303 #endif
 304 #else
 305       i=0
 306 #ifdef WINPGI
 307       idumm=proc_proc(etot,i)
 308 #else
 309       call proc_proc(etot,i)
 310 #endif
 311       if(i.eq.1)energia(0)=1.0d+99
 312 #endif
 313 #ifdef MPL
 314 c     endif
 315 #endif
 316 #ifdef DEBUG
 317       call enerprint(energia,fact)
 318 #endif
 319       if (calc_grad) then
 320 C
 321 C Sum up the components of the Cartesian gradient.
 322 C
 323 #ifdef SPLITELE
 324       do i=1,nct
 325         do j=1,3
 326       if (shield_mode.eq.0) then
 327           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 328      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 329      &                wbond*gradb(j,i)+
 330      &                wstrain*ghpbc(j,i)+
 331      &                wcorr*fact(3)*gradcorr(j,i)+
 332      &                wel_loc*fact(2)*gel_loc(j,i)+
 333      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 334      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 335      &                wcorr5*fact(4)*gradcorr5(j,i)+
 336      &                wcorr6*fact(5)*gradcorr6(j,i)+
 337      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 338      &                wsccor*fact(2)*gsccorc(j,i)+
 339      &                wliptran*gliptranc(j,i)+
 340      &                wdfa_dist*gdfad(j,i)+
 341      &                wdfa_tor*gdfat(j,i)+
 342      &                wdfa_nei*gdfan(j,i)+
 343      &                wdfa_beta*gdfab(j,i)
 344           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 345      &                  wbond*gradbx(j,i)+
 346      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 347      &                  wsccor*fact(2)*gsccorx(j,i)
 348      &                 +wliptran*gliptranx(j,i)
 349         else
 350           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 351      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 352      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 353      &                wbond*gradb(j,i)+
 354      &                wstrain*ghpbc(j,i)+
 355      &                wcorr*fact(3)*gradcorr(j,i)+
 356      &                wel_loc*fact(2)*gel_loc(j,i)+
 357      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 358      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 359      &                wcorr5*fact(4)*gradcorr5(j,i)+
 360      &                wcorr6*fact(5)*gradcorr6(j,i)+
 361      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 362      &                wsccor*fact(2)*gsccorc(j,i)
 363      &               +wliptran*gliptranc(j,i)
 364      &                 +welec*gshieldc(j,i)
 365      &                 +welec*gshieldc_loc(j,i)
 366      &                 +wcorr*gshieldc_ec(j,i)
 367      &                 +wcorr*gshieldc_loc_ec(j,i)
 368      &                 +wturn3*gshieldc_t3(j,i)
 369      &                 +wturn3*gshieldc_loc_t3(j,i)
 370      &                 +wturn4*gshieldc_t4(j,i)
 371      &                 +wturn4*gshieldc_loc_t4(j,i)
 372      &                 +wel_loc*gshieldc_ll(j,i)
 373      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 374      &                wdfa_dist*gdfad(j,i)+
 375      &                wdfa_tor*gdfat(j,i)+
 376      &                wdfa_nei*gdfan(j,i)+
 377      &                wdfa_beta*gdfab(j,i)
 378           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 379      &                 +fact(1)*wscp*gradx_scp(j,i)+
 380      &                  wbond*gradbx(j,i)+
 381      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 382      &                  wsccor*fact(2)*gsccorx(j,i)
 383      &                 +wliptran*gliptranx(j,i)
 384      &                 +welec*gshieldx(j,i)
 385      &                 +wcorr*gshieldx_ec(j,i)
 386      &                 +wturn3*gshieldx_t3(j,i)
 387      &                 +wturn4*gshieldx_t4(j,i)
 388      &                 +wel_loc*gshieldx_ll(j,i)
 389         endif
 390         enddo
 391 #else
 392       do i=1,nct
 393         do j=1,3
 394                 if (shield_mode.eq.0) then
 395           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 396      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 397      &                wbond*gradb(j,i)+
 398      &                wcorr*fact(3)*gradcorr(j,i)+
 399      &                wel_loc*fact(2)*gel_loc(j,i)+
 400      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 401      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 402      &                wcorr5*fact(4)*gradcorr5(j,i)+
 403      &                wcorr6*fact(5)*gradcorr6(j,i)+
 404      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 405      &                wsccor*fact(2)*gsccorc(j,i)
 406      &               +wliptran*gliptranc(j,i)+
 407      &                wdfa_dist*gdfad(j,i)+
 408      &                wdfa_tor*gdfat(j,i)+
 409      &                wdfa_nei*gdfan(j,i)+
 410      &                wdfa_beta*gdfab(j,i)
 411
 412           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 413      &                  wbond*gradbx(j,i)+
 414      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 415      &                  wsccor*fact(1)*gsccorx(j,i)
 416      &                 +wliptran*gliptranx(j,i)
 417               else
 418           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 419      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 420      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 421      &                wbond*gradb(j,i)+
 422      &                wcorr*fact(3)*gradcorr(j,i)+
 423      &                wel_loc*fact(2)*gel_loc(j,i)+
 424      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 425      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 426      &                wcorr5*fact(4)*gradcorr5(j,i)+
 427      &                wcorr6*fact(5)*gradcorr6(j,i)+
 428      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 429      &                wsccor*fact(2)*gsccorc(j,i)
 430      &               +wliptran*gliptranc(j,i)
 431      &                 +welec*gshieldc(j,i)
 432      &                 +welec*gshieldc_loc(j,i)
 433      &                 +wcorr*gshieldc_ec(j,i)
 434      &                 +wcorr*gshieldc_loc_ec(j,i)
 435      &                 +wturn3*gshieldc_t3(j,i)
 436      &                 +wturn3*gshieldc_loc_t3(j,i)
 437      &                 +wturn4*gshieldc_t4(j,i)
 438      &                 +wturn4*gshieldc_loc_t4(j,i)
 439      &                 +wel_loc*gshieldc_ll(j,i)
 440      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 441      &                wdfa_dist*gdfad(j,i)+
 442      &                wdfa_tor*gdfat(j,i)+
 443      &                wdfa_nei*gdfan(j,i)+
 444      &                wdfa_beta*gdfab(j,i)
 445           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 446      &                  fact(1)*wscp*gradx_scp(j,i)+
 447      &                  wbond*gradbx(j,i)+
 448      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 449      &                  wsccor*fact(1)*gsccorx(j,i)
 450      &                 +wliptran*gliptranx(j,i)
 451      &                 +welec*gshieldx(j,i)
 452      &                 +wcorr*gshieldx_ec(j,i)
 453      &                 +wturn3*gshieldx_t3(j,i)
 454      &                 +wturn4*gshieldx_t4(j,i)
 455      &                 +wel_loc*gshieldx_ll(j,i)
 456
 457          endif
 458         enddo
 459 #endif
 460       enddo
 461
 462
 463       do i=1,nres-3
 464         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 465      &   +wcorr5*fact(4)*g_corr5_loc(i)
 466      &   +wcorr6*fact(5)*g_corr6_loc(i)
 467      &   +wturn4*fact(3)*gel_loc_turn4(i)
 468      &   +wturn3*fact(2)*gel_loc_turn3(i)
 469      &   +wturn6*fact(5)*gel_loc_turn6(i)
 470      &   +wel_loc*fact(2)*gel_loc_loc(i)
 471 c     &   +wsccor*fact(1)*gsccor_loc(i)
 472 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 473       enddo
 474       endif
 475       if (dyn_ss) call dyn_set_nss
 476       return
 477       end
 478 C------------------------------------------------------------------------
 479       subroutine enerprint(energia,fact)
 480       implicit real*8 (a-h,o-z)
 481       include 'DIMENSIONS'
 482       include 'DIMENSIONS.ZSCOPT'
 483       include 'COMMON.IOUNITS'
 484       include 'COMMON.FFIELD'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CONTROL'
 487       double precision energia(0:max_ene),fact(6)
 488       etot=energia(0)
 489       evdw=energia(1)+fact(6)*energia(21)
 490 #ifdef SCP14
 491       evdw2=energia(2)+energia(17)
 492 #else
 493       evdw2=energia(2)
 494 #endif
 495       ees=energia(3)
 496 #ifdef SPLITELE
 497       evdw1=energia(16)
 498 #endif
 499       ecorr=energia(4)
 500       ecorr5=energia(5)
 501       ecorr6=energia(6)
 502       eel_loc=energia(7)
 503       eello_turn3=energia(8)
 504       eello_turn4=energia(9)
 505       eello_turn6=energia(10)
 506       ebe=energia(11)
 507       escloc=energia(12)
 508       etors=energia(13)
 509       etors_d=energia(14)
 510       ehpb=energia(15)
 511       esccor=energia(19)
 512       edihcnstr=energia(20)
 513       estr=energia(18)
 514       ethetacnstr=energia(24)
 515       eliptran=energia(22)
 516       esaxs=energia(26)
 517       ehomology_constr=energia(27)
 518 C     Bartek
 519       edfadis = energia(28)
 520       edfator = energia(29)
 521       edfanei = energia(30)
 522       edfabet = energia(31)
 523       Eafmforc=0.0d0
 524       etube=0.0d0
 525       Uconst=0.0d0
 526 #ifdef SPLITELE
 527       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 528      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 529      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 530 #ifdef FOURBODY
 531      &  ecorr,wcorr*fact(3),
 532      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 533 #endif
 534      &  eel_loc,
 535      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 536      &  eello_turn4,wturn4*fact(3),
 537 #ifdef FOURBODY
 538      &  eello_turn6,wturn6*fact(5),
 539 #endif
 540      &  esccor,wsccor*fact(1),edihcnstr,
 541      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 542      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 543      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 544      &  edfabet,wdfa_beta,
 545      &  etot
 546    10 format (/'Virtual-chain energies:'//
 547      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 548      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 549      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 550      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 551      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 552      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 553      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 554      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 555      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 556      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 557      & ' (SS bridges & dist. cnstr.)'/
 558 #ifdef FOURBODY
 559      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 560      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 561      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 562 #endif
 563      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 564      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 565      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 566 #ifdef FOURBODY
 567      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 568 #endif
 569      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 570      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 571      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 572      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 573      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 574      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 575      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 576      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 577      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 578      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 579      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 580      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 581      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 582      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 583      & 'ETOT=  ',1pE16.6,' (total)')
 584
 585 #else
 586       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 587      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 588      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 589 #ifdef FOURBODY
 590      &  ecorr,wcorr*fact(3),
 591      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 592 #endif
 593      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 594      &  eello_turn4,wturn4*fact(3),
 595 #ifdef FOURBODY
 596      &  eello_turn6,wturn6*fact(5),
 597 #endif
 598      &  esccor,wsccor*fact(1),edihcnstr,
 599      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 600      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 601      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 602      &  edfabet,wdfa_beta,
 603      &  etot
 604    10 format (/'Virtual-chain energies:'//
 605      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 606      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 607      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 608      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 609      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 610      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 611      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 612      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 613      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 614      & ' (SS bridges & dist. restr.)'/
 615 #ifdef FOURBODY
 616      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 617      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 618      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 619 #endif
 620      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 621      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 622      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 623 #ifdef FOURBODY
 624      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 625 #endif
 626      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 627      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 628      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 629      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 630      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 631      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 632      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 633      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 634      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 635      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 636      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 637      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 638      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 639      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 640      & 'ETOT=  ',1pE16.6,' (total)')
 641 #endif
 642       return
 643       end
 644 C-----------------------------------------------------------------------
 645       subroutine elj(evdw,evdw_t)
 646 C
 647 C This subroutine calculates the interaction energy of nonbonded side chains
 648 C assuming the LJ potential of interaction.
 649 C
 650       implicit real*8 (a-h,o-z)
 651       include 'DIMENSIONS'
 652       include 'DIMENSIONS.ZSCOPT'
 653       include "DIMENSIONS.COMPAR"
 654       parameter (accur=1.0d-10)
 655       include 'COMMON.GEO'
 656       include 'COMMON.VAR'
 657       include 'COMMON.LOCAL'
 658       include 'COMMON.CHAIN'
 659       include 'COMMON.DERIV'
 660       include 'COMMON.INTERACT'
 661       include 'COMMON.TORSION'
 662       include 'COMMON.ENEPS'
 663       include 'COMMON.SBRIDGE'
 664       include 'COMMON.NAMES'
 665       include 'COMMON.IOUNITS'
 666 #ifdef FOURBODY
 667       include 'COMMON.CONTACTS'
 668       include 'COMMON.CONTMAT'
 669 #endif
 670       dimension gg(3)
 671       integer icant
 672       external icant
 673 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 674 c ROZNICA z cluster
 675       do i=1,210
 676         do j=1,2
 677           eneps_temp(j,i)=0.0d0
 678         enddo
 679       enddo
 680 cROZNICA
 681
 682       evdw=0.0D0
 683       evdw_t=0.0d0
 684       do i=iatsc_s,iatsc_e
 685         itypi=iabs(itype(i))
 686         if (itypi.eq.ntyp1) cycle
 687         itypi1=iabs(itype(i+1))
 688         xi=c(1,nres+i)
 689         yi=c(2,nres+i)
 690         zi=c(3,nres+i)
 691         call to_box(xi,yi,zi)
 692 C Change 12/1/95
 693         num_conti=0
 694 C
 695 C Calculate SC interaction energy.
 696 C
 697         do iint=1,nint_gr(i)
 698 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 699 cd   &                  'iend=',iend(i,iint)
 700           do j=istart(i,iint),iend(i,iint)
 701             itypj=iabs(itype(j))
 702             if (itypj.eq.ntyp1) cycle
 703             xj=c(1,nres+j)-xi
 704             yj=c(2,nres+j)-yi
 705             zj=c(3,nres+j)-zi
 706             call to_box(xj,yj,zj)
 707             xj=boxshift(xj-xi,boxxsize)
 708             yj=boxshift(yj-yi,boxysize)
 709             zj=boxshift(zj-zi,boxzsize)
 710 C Change 12/1/95 to calculate four-body interactions
 711             rij=xj*xj+yj*yj+zj*zj
 712             rrij=1.0D0/rij
 713             sqrij=dsqrt(rij)
 714             sss1=sscale(sqrij)
 715             if (sss1.eq.0.0d0) cycle
 716             sssgrad1=sscagrad(sqrij)
 717 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 718             eps0ij=eps(itypi,itypj)
 719             fac=rrij**expon2
 720             e1=fac*fac*aa
 721             e2=fac*bb
 722             evdwij=e1+e2
 723             ij=icant(itypi,itypj)
 724 c ROZNICA z cluster
 725             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 726             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 727 c
 728
 729 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 730 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 731 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 732 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 733 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 734 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 735             if (bb.gt.0.0d0) then
 736               evdw=evdw+sss1*evdwij
 737             else
 738               evdw_t=evdw_t+sss1*evdwij
 739             endif
 740             if (calc_grad) then
 741 C
 742 C Calculate the components of the gradient in DC and X
 743 C
 744             fac=-rrij*(e1+evdwij)*sss1
 745      &          +evdwij*sssgrad1/sqrij/expon
 746             gg(1)=xj*fac
 747             gg(2)=yj*fac
 748             gg(3)=zj*fac
 749             do k=1,3
 750               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 751               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 752             enddo
 753             do k=i,j-1
 754               do l=1,3
 755                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 756               enddo
 757             enddo
 758             endif
 759 #ifdef FOURBODY
 760 C
 761 C 12/1/95, revised on 5/20/97
 762 C
 763 C Calculate the contact function. The ith column of the array JCONT will
 764 C contain the numbers of atoms that make contacts with the atom I (of numbers
 765 C greater than I). The arrays FACONT and GACONT will contain the values of
 766 C the contact function and its derivative.
 767 C
 768 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 769 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 770 C Uncomment next line, if the correlation interactions are contact function only
 771             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 772               rij=dsqrt(rij)
 773               sigij=sigma(itypi,itypj)
 774               r0ij=rs0(itypi,itypj)
 775 C
 776 C Check whether the SC's are not too far to make a contact.
 777 C
 778               rcut=1.5d0*r0ij
 779               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 780 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 781 C
 782               if (fcont.gt.0.0D0) then
 783 C If the SC-SC distance if close to sigma, apply spline.
 784 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 785 cAdam &             fcont1,fprimcont1)
 786 cAdam           fcont1=1.0d0-fcont1
 787 cAdam           if (fcont1.gt.0.0d0) then
 788 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 789 cAdam             fcont=fcont*fcont1
 790 cAdam           endif
 791 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 792 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 793 cga             do k=1,3
 794 cga               gg(k)=gg(k)*eps0ij
 795 cga             enddo
 796 cga             eps0ij=-evdwij*eps0ij
 797 C Uncomment for AL's type of SC correlation interactions.
 798 cadam           eps0ij=-evdwij
 799                 num_conti=num_conti+1
 800                 jcont(num_conti,i)=j
 801                 facont(num_conti,i)=fcont*eps0ij
 802                 fprimcont=eps0ij*fprimcont/rij
 803                 fcont=expon*fcont
 804 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 805 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 806 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 807 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 808                 gacont(1,num_conti,i)=-fprimcont*xj
 809                 gacont(2,num_conti,i)=-fprimcont*yj
 810                 gacont(3,num_conti,i)=-fprimcont*zj
 811 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 812 cd              write (iout,'(2i3,3f10.5)')
 813 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 814               endif
 815             endif
 816 #endif
 817           enddo      ! j
 818         enddo        ! iint
 819 #ifdef FOURBODY
 820 C Change 12/1/95
 821         num_cont(i)=num_conti
 822 #endif
 823       enddo          ! i
 824       if (calc_grad) then
 825       do i=1,nct
 826         do j=1,3
 827           gvdwc(j,i)=expon*gvdwc(j,i)
 828           gvdwx(j,i)=expon*gvdwx(j,i)
 829         enddo
 830       enddo
 831       endif
 832 C******************************************************************************
 833 C
 834 C                              N O T E !!!
 835 C
 836 C To save time, the factor of EXPON has been extracted from ALL components
 837 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 838 C use!
 839 C
 840 C******************************************************************************
 841       return
 842       end
 843 C-----------------------------------------------------------------------------
 844       subroutine eljk(evdw,evdw_t)
 845 C
 846 C This subroutine calculates the interaction energy of nonbonded side chains
 847 C assuming the LJK potential of interaction.
 848 C
 849       implicit real*8 (a-h,o-z)
 850       include 'DIMENSIONS'
 851       include 'DIMENSIONS.ZSCOPT'
 852       include "DIMENSIONS.COMPAR"
 853       include 'COMMON.GEO'
 854       include 'COMMON.VAR'
 855       include 'COMMON.LOCAL'
 856       include 'COMMON.CHAIN'
 857       include 'COMMON.DERIV'
 858       include 'COMMON.INTERACT'
 859       include 'COMMON.ENEPS'
 860       include 'COMMON.IOUNITS'
 861       include 'COMMON.NAMES'
 862       dimension gg(3)
 863       logical scheck
 864       integer icant
 865       external icant
 866 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 867       do i=1,210
 868         do j=1,2
 869           eneps_temp(j,i)=0.0d0
 870         enddo
 871       enddo
 872       evdw=0.0D0
 873       evdw_t=0.0d0
 874       do i=iatsc_s,iatsc_e
 875         itypi=iabs(itype(i))
 876         if (itypi.eq.ntyp1) cycle
 877         itypi1=iabs(itype(i+1))
 878         xi=c(1,nres+i)
 879         yi=c(2,nres+i)
 880         zi=c(3,nres+i)
 881         call to_box(xi,yi,zi)
 882 C
 883 C Calculate SC interaction energy.
 884 C
 885         do iint=1,nint_gr(i)
 886           do j=istart(i,iint),iend(i,iint)
 887             itypj=iabs(itype(j))
 888             if (itypj.eq.ntyp1) cycle
 889             xj=c(1,nres+j)-xi
 890             yj=c(2,nres+j)-yi
 891             zj=c(3,nres+j)-zi
 892             call to_box(xj,yj,zj)
 893             xj=boxshift(xj-xi,boxxsize)
 894             yj=boxshift(yj-yi,boxysize)
 895             zj=boxshift(zj-zi,boxzsize)
 896             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 897             fac_augm=rrij**expon
 898             e_augm=augm(itypi,itypj)*fac_augm
 899             r_inv_ij=dsqrt(rrij)
 900             rij=1.0D0/r_inv_ij
 901             sss1=sscale(rij)
 902             if (sss1.eq.0.0d0) cycle
 903             sssgrad1=sscagrad(rij)
 904             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 905             fac=r_shift_inv**expon
 906             e1=fac*fac*aa
 907             e2=fac*bb
 908             evdwij=e_augm+e1+e2
 909             ij=icant(itypi,itypj)
 910             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 911      &        /dabs(eps(itypi,itypj))
 912             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 913 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 914 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 915 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 916 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 917 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 918 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 919 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 920             if (bb.gt.0.0d0) then
 921               evdw=evdw+evdwij*sss1
 922             else
 923               evdw_t=evdw_t+evdwij*sss1
 924             endif
 925             if (calc_grad) then
 926 C
 927 C Calculate the components of the gradient in DC and X
 928 C
 929            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 930      &          +evdwij*sssgrad1*r_inv_ij/expon
 931             gg(1)=xj*fac
 932             gg(2)=yj*fac
 933             gg(3)=zj*fac
 934             do k=1,3
 935               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 936               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 937             enddo
 938             do k=i,j-1
 939               do l=1,3
 940                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 941               enddo
 942             enddo
 943             endif
 944           enddo      ! j
 945         enddo        ! iint
 946       enddo          ! i
 947       if (calc_grad) then
 948       do i=1,nct
 949         do j=1,3
 950           gvdwc(j,i)=expon*gvdwc(j,i)
 951           gvdwx(j,i)=expon*gvdwx(j,i)
 952         enddo
 953       enddo
 954       endif
 955       return
 956       end
 957 C-----------------------------------------------------------------------------
 958       subroutine ebp(evdw,evdw_t)
 959 C
 960 C This subroutine calculates the interaction energy of nonbonded side chains
 961 C assuming the Berne-Pechukas potential of interaction.
 962 C
 963       implicit real*8 (a-h,o-z)
 964       include 'DIMENSIONS'
 965       include 'DIMENSIONS.ZSCOPT'
 966       include "DIMENSIONS.COMPAR"
 967       include 'COMMON.GEO'
 968       include 'COMMON.VAR'
 969       include 'COMMON.LOCAL'
 970       include 'COMMON.CHAIN'
 971       include 'COMMON.DERIV'
 972       include 'COMMON.NAMES'
 973       include 'COMMON.INTERACT'
 974       include 'COMMON.ENEPS'
 975       include 'COMMON.IOUNITS'
 976       include 'COMMON.CALC'
 977       common /srutu/ icall
 978 c     double precision rrsave(maxdim)
 979       logical lprn
 980       integer icant
 981       external icant
 982       do i=1,210
 983         do j=1,2
 984           eneps_temp(j,i)=0.0d0
 985         enddo
 986       enddo
 987       evdw=0.0D0
 988       evdw_t=0.0d0
 989 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 990 c     if (icall.eq.0) then
 991 c       lprn=.true.
 992 c     else
 993         lprn=.false.
 994 c     endif
 995       ind=0
 996       do i=iatsc_s,iatsc_e
 997         itypi=iabs(itype(i))
 998         if (itypi.eq.ntyp1) cycle
 999         itypi1=iabs(itype(i+1))
1000         xi=c(1,nres+i)
1001         yi=c(2,nres+i)
1002         zi=c(3,nres+i)
1003         call to_box(xi,yi,zi)
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             ind=ind+1
1014             itypj=iabs(itype(j))
1015             if (itypj.eq.ntyp1) cycle
1016             dscj_inv=vbld_inv(j+nres)
1017             chi1=chi(itypi,itypj)
1018             chi2=chi(itypj,itypi)
1019             chi12=chi1*chi2
1020             chip1=chip(itypi)
1021             chip2=chip(itypj)
1022             chip12=chip1*chip2
1023             alf1=alp(itypi)
1024             alf2=alp(itypj)
1025             alf12=0.5D0*(alf1+alf2)
1026 C For diagnostics only!!!
1027 c           chi1=0.0D0
1028 c           chi2=0.0D0
1029 c           chi12=0.0D0
1030 c           chip1=0.0D0
1031 c           chip2=0.0D0
1032 c           chip12=0.0D0
1033 c           alf1=0.0D0
1034 c           alf2=0.0D0
1035 c           alf12=0.0D0
1036             xj=c(1,nres+j)
1037             yj=c(2,nres+j)
1038             zj=c(3,nres+j)
1039             call to_box(xj,yj,zj)
1040             xj=boxshift(xj-xi,boxxsize)
1041             yj=boxshift(yj-yi,boxysize)
1042             zj=boxshift(zj-zi,boxzsize)
1043             dxj=dc_norm(1,nres+j)
1044             dyj=dc_norm(2,nres+j)
1045             dzj=dc_norm(3,nres+j)
1046             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1047 cd          if (icall.eq.0) then
1048 cd            rrsave(ind)=rrij
1049 cd          else
1050 cd            rrij=rrsave(ind)
1051 cd          endif
1052             rij=dsqrt(rrij)
1053             sss1=sscale(1.0d0/rij)
1054             if (sss1.eq.0.0d0) cycle
1055             sssgrad1=sscagrad(1.0d0/rij)
1056
1057 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1058             call sc_angular
1059 C Calculate whole angle-dependent part of epsilon and contributions
1060 C to its derivatives
1061             fac=(rrij*sigsq)**expon2
1062             e1=fac*fac*aa
1063             e2=fac*bb
1064             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1065             eps2der=evdwij*eps3rt
1066             eps3der=evdwij*eps2rt
1067             evdwij=evdwij*eps2rt*eps3rt
1068             ij=icant(itypi,itypj)
1069             aux=eps1*eps2rt**2*eps3rt**2
1070             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1071      &        /dabs(eps(itypi,itypj))
1072             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1073             if (bb.gt.0.0d0) then
1074               evdw=evdw+sss1*evdwij
1075             else
1076               evdw_t=evdw_t+sss1*evdwij
1077             endif
1078             if (calc_grad) then
1079             if (lprn) then
1080             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1081             epsi=bb**2/aa
1082             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1083      &        restyp(itypi),i,restyp(itypj),j,
1084      &        epsi,sigm,chi1,chi2,chip1,chip2,
1085      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1086      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1087      &        evdwij
1088             endif
1089 C Calculate gradient components.
1090             e1=e1*eps1*eps2rt**2*eps3rt**2
1091             fac=-expon*(e1+evdwij)
1092             sigder=fac/sigsq
1093             fac=rrij*fac
1094      &           +evdwij*sssgrad1/sss1*rij
1095 C Calculate radial part of the gradient
1096             gg(1)=xj*fac
1097             gg(2)=yj*fac
1098             gg(3)=zj*fac
1099 C Calculate the angular part of the gradient and sum add the contributions
1100 C to the appropriate components of the Cartesian gradient.
1101             call sc_grad
1102             endif
1103           enddo      ! j
1104         enddo        ! iint
1105       enddo          ! i
1106 c     stop
1107       return
1108       end
1109 C-----------------------------------------------------------------------------
1110       subroutine egb(evdw,evdw_t)
1111 C
1112 C This subroutine calculates the interaction energy of nonbonded side chains
1113 C assuming the Gay-Berne potential of interaction.
1114 C
1115       implicit real*8 (a-h,o-z)
1116       include 'DIMENSIONS'
1117       include 'DIMENSIONS.ZSCOPT'
1118       include "DIMENSIONS.COMPAR"
1119       include 'COMMON.CONTROL'
1120       include 'COMMON.GEO'
1121       include 'COMMON.VAR'
1122       include 'COMMON.LOCAL'
1123       include 'COMMON.CHAIN'
1124       include 'COMMON.DERIV'
1125       include 'COMMON.NAMES'
1126       include 'COMMON.INTERACT'
1127       include 'COMMON.ENEPS'
1128       include 'COMMON.IOUNITS'
1129       include 'COMMON.CALC'
1130       include 'COMMON.SBRIDGE'
1131       logical lprn
1132       common /srutu/icall
1133       integer icant,xshift,yshift,zshift
1134       external icant
1135       do i=1,210
1136         do j=1,2
1137           eneps_temp(j,i)=0.0d0
1138         enddo
1139       enddo
1140 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1141       evdw=0.0D0
1142       evdw_t=0.0d0
1143       lprn=.false.
1144 c      if (icall.gt.0) lprn=.true.
1145       ind=0
1146       do i=iatsc_s,iatsc_e
1147         itypi=iabs(itype(i))
1148         if (itypi.eq.ntyp1) cycle
1149         itypi1=iabs(itype(i+1))
1150         xi=c(1,nres+i)
1151         yi=c(2,nres+i)
1152         zi=c(3,nres+i)
1153 C returning the ith atom to box
1154         call to_box(xi,yi,zi)
1155         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1156         dxi=dc_norm(1,nres+i)
1157         dyi=dc_norm(2,nres+i)
1158         dzi=dc_norm(3,nres+i)
1159         dsci_inv=vbld_inv(i+nres)
1160 C
1161 C Calculate SC interaction energy.
1162 C
1163         do iint=1,nint_gr(i)
1164           do j=istart(i,iint),iend(i,iint)
1165             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1166               call dyn_ssbond_ene(i,j,evdwij)
1167               evdw=evdw+evdwij
1168 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1169 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1170 C triple bond artifac removal
1171              do k=j+1,iend(i,iint)
1172 C search over all next residues
1173               if (dyn_ss_mask(k)) then
1174 C check if they are cysteins
1175 C              write(iout,*) 'k=',k
1176               call triple_ssbond_ene(i,j,k,evdwij)
1177 C call the energy function that removes the artifical triple disulfide
1178 C bond the soubroutine is located in ssMD.F
1179               evdw=evdw+evdwij
1180 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1181 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1182               endif!dyn_ss_mask(k)
1183              enddo! k
1184             ELSE
1185             ind=ind+1
1186             itypj=iabs(itype(j))
1187             if (itypj.eq.ntyp1) cycle
1188             dscj_inv=vbld_inv(j+nres)
1189             sig0ij=sigma(itypi,itypj)
1190             chi1=chi(itypi,itypj)
1191             chi2=chi(itypj,itypi)
1192             chi12=chi1*chi2
1193             chip1=chip(itypi)
1194             chip2=chip(itypj)
1195             chip12=chip1*chip2
1196             alf1=alp(itypi)
1197             alf2=alp(itypj)
1198             alf12=0.5D0*(alf1+alf2)
1199 C For diagnostics only!!!
1200 c           chi1=0.0D0
1201 c           chi2=0.0D0
1202 c           chi12=0.0D0
1203 c           chip1=0.0D0
1204 c           chip2=0.0D0
1205 c           chip12=0.0D0
1206 c           alf1=0.0D0
1207 c           alf2=0.0D0
1208 c           alf12=0.0D0
1209             xj=c(1,nres+j)
1210             yj=c(2,nres+j)
1211             zj=c(3,nres+j)
1212 C returning jth atom to box
1213             call to_box(xj,yj,zj)
1214             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1215             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1216      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1217             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1218      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1219             xj=boxshift(xj-xi,boxxsize)
1220             yj=boxshift(yj-yi,boxysize)
1221             zj=boxshift(zj-zi,boxzsize)
1222             dxj=dc_norm(1,nres+j)
1223             dyj=dc_norm(2,nres+j)
1224             dzj=dc_norm(3,nres+j)
1225 c            write (iout,*) i,j,xj,yj,zj
1226             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1227             rij=dsqrt(rrij)
1228             sss=sscale(1.0d0/rij)
1229             sssgrad=sscagrad(1.0d0/rij)
1230             if (sss.le.0.0) cycle
1231 C Calculate angle-dependent terms of energy and contributions to their
1232 C derivatives.
1233
1234             call sc_angular
1235             sigsq=1.0D0/sigsq
1236             sig=sig0ij*dsqrt(sigsq)
1237             rij_shift=1.0D0/rij-sig+sig0ij
1238 C I hate to put IF's in the loops, but here don't have another choice!!!!
1239             if (rij_shift.le.0.0D0) then
1240               evdw=1.0D20
1241               return
1242             endif
1243             sigder=-sig*sigsq
1244 c---------------------------------------------------------------
1245             rij_shift=1.0D0/rij_shift
1246             fac=rij_shift**expon
1247             e1=fac*fac*aa
1248             e2=fac*bb
1249             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1250             eps2der=evdwij*eps3rt
1251             eps3der=evdwij*eps2rt
1252             evdwij=evdwij*eps2rt*eps3rt
1253             if (bb.gt.0) then
1254               evdw=evdw+evdwij*sss
1255             else
1256               evdw_t=evdw_t+evdwij*sss
1257             endif
1258             ij=icant(itypi,itypj)
1259             aux=eps1*eps2rt**2*eps3rt**2
1260             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1261      &        /dabs(eps(itypi,itypj))
1262             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1263 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1264 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1265 c     &         aux*e2/eps(itypi,itypj)
1266 c            if (lprn) then
1267             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1268             epsi=bb**2/aa
1269 c#define DEBUG
1270 #ifdef DEBUG
1271             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1272      &        restyp(itypi),i,restyp(itypj),j,
1273      &        epsi,sigm,chi1,chi2,chip1,chip2,
1274      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1275      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1276      &        evdwij
1277              write (iout,*) "partial sum", evdw, evdw_t
1278 #endif
1279 c#undef DEBUG
1280 c            endif
1281             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
1282      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
1283             if (calc_grad) then
1284 C Calculate gradient components.
1285             e1=e1*eps1*eps2rt**2*eps3rt**2
1286             fac=-expon*(e1+evdwij)*rij_shift
1287             sigder=fac*sigder
1288             fac=rij*fac
1289             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1290 C Calculate the radial part of the gradient
1291             gg(1)=xj*fac
1292             gg(2)=yj*fac
1293             gg(3)=zj*fac
1294 C Calculate angular part of the gradient.
1295             call sc_grad
1296             endif
1297 C            write(iout,*)  "partial sum", evdw, evdw_t
1298             ENDIF    ! dyn_ss
1299           enddo      ! j
1300         enddo        ! iint
1301       enddo          ! i
1302       return
1303       end
1304 C-----------------------------------------------------------------------------
1305       subroutine egbv(evdw,evdw_t)
1306 C
1307 C This subroutine calculates the interaction energy of nonbonded side chains
1308 C assuming the Gay-Berne-Vorobjev potential of interaction.
1309 C
1310       implicit real*8 (a-h,o-z)
1311       include 'DIMENSIONS'
1312       include 'DIMENSIONS.ZSCOPT'
1313       include "DIMENSIONS.COMPAR"
1314       include 'COMMON.GEO'
1315       include 'COMMON.VAR'
1316       include 'COMMON.LOCAL'
1317       include 'COMMON.CHAIN'
1318       include 'COMMON.DERIV'
1319       include 'COMMON.NAMES'
1320       include 'COMMON.INTERACT'
1321       include 'COMMON.ENEPS'
1322       include 'COMMON.IOUNITS'
1323       include 'COMMON.CALC'
1324       common /srutu/ icall
1325       logical lprn
1326       integer icant
1327       external icant
1328       do i=1,210
1329         do j=1,2
1330           eneps_temp(j,i)=0.0d0
1331         enddo
1332       enddo
1333       evdw=0.0D0
1334       evdw_t=0.0d0
1335 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1336       evdw=0.0D0
1337       lprn=.false.
1338 c      if (icall.gt.0) lprn=.true.
1339       ind=0
1340       do i=iatsc_s,iatsc_e
1341         itypi=iabs(itype(i))
1342         if (itypi.eq.ntyp1) cycle
1343         itypi1=iabs(itype(i+1))
1344         xi=c(1,nres+i)
1345         yi=c(2,nres+i)
1346         zi=c(3,nres+i)
1347         call to_box(xi,yi,zi)
1348         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1349         dxi=dc_norm(1,nres+i)
1350         dyi=dc_norm(2,nres+i)
1351         dzi=dc_norm(3,nres+i)
1352         dsci_inv=vbld_inv(i+nres)
1353 C
1354 C Calculate SC interaction energy.
1355 C
1356         do iint=1,nint_gr(i)
1357           do j=istart(i,iint),iend(i,iint)
1358             ind=ind+1
1359             itypj=iabs(itype(j))
1360             if (itypj.eq.ntyp1) cycle
1361             dscj_inv=vbld_inv(j+nres)
1362             sig0ij=sigma(itypi,itypj)
1363             r0ij=r0(itypi,itypj)
1364             chi1=chi(itypi,itypj)
1365             chi2=chi(itypj,itypi)
1366             chi12=chi1*chi2
1367             chip1=chip(itypi)
1368             chip2=chip(itypj)
1369             chip12=chip1*chip2
1370             alf1=alp(itypi)
1371             alf2=alp(itypj)
1372             alf12=0.5D0*(alf1+alf2)
1373 C For diagnostics only!!!
1374 c           chi1=0.0D0
1375 c           chi2=0.0D0
1376 c           chi12=0.0D0
1377 c           chip1=0.0D0
1378 c           chip2=0.0D0
1379 c           chip12=0.0D0
1380 c           alf1=0.0D0
1381 c           alf2=0.0D0
1382 c           alf12=0.0D0
1383             xj=c(1,nres+j)
1384             yj=c(2,nres+j)
1385             zj=c(3,nres+j)
1386             call to_box(xj,yj,zj)
1387             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1388             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1389      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1390             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1391      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1392 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1393 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1394 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
1395             xj=boxshift(xj-xi,boxxsize)
1396             yj=boxshift(yj-yi,boxysize)
1397             zj=boxshift(zj-zi,boxzsize)
1398             dxj=dc_norm(1,nres+j)
1399             dyj=dc_norm(2,nres+j)
1400             dzj=dc_norm(3,nres+j)
1401             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1402             rij=dsqrt(rrij)
1403             sss=sscale(1.0d0/rij)
1404             if (sss.eq.0.0d0) cycle
1405             sssgrad=sscagrad(1.0d0/rij)
1406 C Calculate angle-dependent terms of energy and contributions to their
1407 C derivatives.
1408             call sc_angular
1409             sigsq=1.0D0/sigsq
1410             sig=sig0ij*dsqrt(sigsq)
1411             rij_shift=1.0D0/rij-sig+r0ij
1412 C I hate to put IF's in the loops, but here don't have another choice!!!!
1413             if (rij_shift.le.0.0D0) then
1414               evdw=1.0D20
1415               return
1416             endif
1417             sigder=-sig*sigsq
1418 c---------------------------------------------------------------
1419             rij_shift=1.0D0/rij_shift
1420             fac=rij_shift**expon
1421             e1=fac*fac*aa
1422             e2=fac*bb
1423             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1424             eps2der=evdwij*eps3rt
1425             eps3der=evdwij*eps2rt
1426             fac_augm=rrij**expon
1427             e_augm=augm(itypi,itypj)*fac_augm
1428             evdwij=evdwij*eps2rt*eps3rt
1429             if (bb.gt.0.0d0) then
1430               evdw=evdw+(evdwij+e_augm)*sss
1431             else
1432               evdw_t=evdw_t+(evdwij+e_augm)*sss
1433             endif
1434             ij=icant(itypi,itypj)
1435             aux=eps1*eps2rt**2*eps3rt**2
1436             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1437      &        /dabs(eps(itypi,itypj))
1438             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1439 c            eneps_temp(ij)=eneps_temp(ij)
1440 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1441 c            if (lprn) then
1442 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1443 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1444 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1445 c     &        restyp(itypi),i,restyp(itypj),j,
1446 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1447 c     &        chi1,chi2,chip1,chip2,
1448 c     &        eps1,eps2rt**2,eps3rt**2,
1449 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1450 c     &        evdwij+e_augm
1451 c            endif
1452             if (calc_grad) then
1453 C Calculate gradient components.
1454             e1=e1*eps1*eps2rt**2*eps3rt**2
1455             fac=-expon*(e1+evdwij)*rij_shift
1456             sigder=fac*sigder
1457             fac=rij*fac-2*expon*rrij*e_augm
1458             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1459 C Calculate the radial part of the gradient
1460             gg(1)=xj*fac
1461             gg(2)=yj*fac
1462             gg(3)=zj*fac
1463 C Calculate angular part of the gradient.
1464             call sc_grad
1465             endif
1466           enddo      ! j
1467         enddo        ! iint
1468       enddo          ! i
1469       return
1470       end
1471 C-----------------------------------------------------------------------------
1472       subroutine sc_angular
1473 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1474 C om12. Called by ebp, egb, and egbv.
1475       implicit none
1476       include 'COMMON.CALC'
1477       erij(1)=xj*rij
1478       erij(2)=yj*rij
1479       erij(3)=zj*rij
1480       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1481       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1482       om12=dxi*dxj+dyi*dyj+dzi*dzj
1483       chiom12=chi12*om12
1484 C Calculate eps1(om12) and its derivative in om12
1485       faceps1=1.0D0-om12*chiom12
1486       faceps1_inv=1.0D0/faceps1
1487       eps1=dsqrt(faceps1_inv)
1488 C Following variable is eps1*deps1/dom12
1489       eps1_om12=faceps1_inv*chiom12
1490 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1491 C and om12.
1492       om1om2=om1*om2
1493       chiom1=chi1*om1
1494       chiom2=chi2*om2
1495       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1496       sigsq=1.0D0-facsig*faceps1_inv
1497       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1498       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1499       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1500 C Calculate eps2 and its derivatives in om1, om2, and om12.
1501       chipom1=chip1*om1
1502       chipom2=chip2*om2
1503       chipom12=chip12*om12
1504       facp=1.0D0-om12*chipom12
1505       facp_inv=1.0D0/facp
1506       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1507 C Following variable is the square root of eps2
1508       eps2rt=1.0D0-facp1*facp_inv
1509 C Following three variables are the derivatives of the square root of eps
1510 C in om1, om2, and om12.
1511       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1512       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1513       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1514 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1515       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1516 C Calculate whole angle-dependent part of epsilon and contributions
1517 C to its derivatives
1518       return
1519       end
1520 C----------------------------------------------------------------------------
1521       subroutine sc_grad
1522       implicit real*8 (a-h,o-z)
1523       include 'DIMENSIONS'
1524       include 'DIMENSIONS.ZSCOPT'
1525       include 'COMMON.CHAIN'
1526       include 'COMMON.DERIV'
1527       include 'COMMON.CALC'
1528       double precision dcosom1(3),dcosom2(3)
1529       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1530       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1531       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1532      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1533       do k=1,3
1534         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1535         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1536       enddo
1537       do k=1,3
1538         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1539       enddo
1540       do k=1,3
1541         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1542      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1543      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1544         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1545      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1546      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1547       enddo
1548 C
1549 C Calculate the components of the gradient in DC and X
1550 C
1551       do k=i,j-1
1552         do l=1,3
1553           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1554         enddo
1555       enddo
1556       return
1557       end
1558 c------------------------------------------------------------------------------
1559       subroutine vec_and_deriv
1560       implicit real*8 (a-h,o-z)
1561       include 'DIMENSIONS'
1562       include 'DIMENSIONS.ZSCOPT'
1563       include 'COMMON.IOUNITS'
1564       include 'COMMON.GEO'
1565       include 'COMMON.VAR'
1566       include 'COMMON.LOCAL'
1567       include 'COMMON.CHAIN'
1568       include 'COMMON.VECTORS'
1569       include 'COMMON.DERIV'
1570       include 'COMMON.INTERACT'
1571       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1572 C Compute the local reference systems. For reference system (i), the
1573 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1574 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1575       do i=1,nres-1
1576 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1577           if (i.eq.nres-1) then
1578 C Case of the last full residue
1579 C Compute the Z-axis
1580             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1581             costh=dcos(pi-theta(nres))
1582             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1583 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1584 c     &         " uz",uz(:,i)
1585             do k=1,3
1586               uz(k,i)=fac*uz(k,i)
1587             enddo
1588             if (calc_grad) then
1589 C Compute the derivatives of uz
1590             uzder(1,1,1)= 0.0d0
1591             uzder(2,1,1)=-dc_norm(3,i-1)
1592             uzder(3,1,1)= dc_norm(2,i-1)
1593             uzder(1,2,1)= dc_norm(3,i-1)
1594             uzder(2,2,1)= 0.0d0
1595             uzder(3,2,1)=-dc_norm(1,i-1)
1596             uzder(1,3,1)=-dc_norm(2,i-1)
1597             uzder(2,3,1)= dc_norm(1,i-1)
1598             uzder(3,3,1)= 0.0d0
1599             uzder(1,1,2)= 0.0d0
1600             uzder(2,1,2)= dc_norm(3,i)
1601             uzder(3,1,2)=-dc_norm(2,i)
1602             uzder(1,2,2)=-dc_norm(3,i)
1603             uzder(2,2,2)= 0.0d0
1604             uzder(3,2,2)= dc_norm(1,i)
1605             uzder(1,3,2)= dc_norm(2,i)
1606             uzder(2,3,2)=-dc_norm(1,i)
1607             uzder(3,3,2)= 0.0d0
1608             endif ! calc_grad
1609 C Compute the Y-axis
1610             facy=fac
1611             do k=1,3
1612               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1613             enddo
1614             if (calc_grad) then
1615 C Compute the derivatives of uy
1616             do j=1,3
1617               do k=1,3
1618                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1619      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1620                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1621               enddo
1622               uyder(j,j,1)=uyder(j,j,1)-costh
1623               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1624             enddo
1625             do j=1,2
1626               do k=1,3
1627                 do l=1,3
1628                   uygrad(l,k,j,i)=uyder(l,k,j)
1629                   uzgrad(l,k,j,i)=uzder(l,k,j)
1630                 enddo
1631               enddo
1632             enddo
1633             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1634             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1635             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1636             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1637             endif
1638           else
1639 C Other residues
1640 C Compute the Z-axis
1641             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1642             costh=dcos(pi-theta(i+2))
1643             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1644             do k=1,3
1645               uz(k,i)=fac*uz(k,i)
1646             enddo
1647             if (calc_grad) then
1648 C Compute the derivatives of uz
1649             uzder(1,1,1)= 0.0d0
1650             uzder(2,1,1)=-dc_norm(3,i+1)
1651             uzder(3,1,1)= dc_norm(2,i+1)
1652             uzder(1,2,1)= dc_norm(3,i+1)
1653             uzder(2,2,1)= 0.0d0
1654             uzder(3,2,1)=-dc_norm(1,i+1)
1655             uzder(1,3,1)=-dc_norm(2,i+1)
1656             uzder(2,3,1)= dc_norm(1,i+1)
1657             uzder(3,3,1)= 0.0d0
1658             uzder(1,1,2)= 0.0d0
1659             uzder(2,1,2)= dc_norm(3,i)
1660             uzder(3,1,2)=-dc_norm(2,i)
1661             uzder(1,2,2)=-dc_norm(3,i)
1662             uzder(2,2,2)= 0.0d0
1663             uzder(3,2,2)= dc_norm(1,i)
1664             uzder(1,3,2)= dc_norm(2,i)
1665             uzder(2,3,2)=-dc_norm(1,i)
1666             uzder(3,3,2)= 0.0d0
1667             endif
1668 C Compute the Y-axis
1669             facy=fac
1670             do k=1,3
1671               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1672             enddo
1673             if (calc_grad) then
1674 C Compute the derivatives of uy
1675             do j=1,3
1676               do k=1,3
1677                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1678      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1679                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1680               enddo
1681               uyder(j,j,1)=uyder(j,j,1)-costh
1682               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1683             enddo
1684             do j=1,2
1685               do k=1,3
1686                 do l=1,3
1687                   uygrad(l,k,j,i)=uyder(l,k,j)
1688                   uzgrad(l,k,j,i)=uzder(l,k,j)
1689                 enddo
1690               enddo
1691             enddo
1692             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1693             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1694             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1695             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1696           endif
1697           endif
1698       enddo
1699       if (calc_grad) then
1700       do i=1,nres-1
1701         vbld_inv_temp(1)=vbld_inv(i+1)
1702         if (i.lt.nres-1) then
1703           vbld_inv_temp(2)=vbld_inv(i+2)
1704         else
1705           vbld_inv_temp(2)=vbld_inv(i)
1706         endif
1707         do j=1,2
1708           do k=1,3
1709             do l=1,3
1710               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1711               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1712             enddo
1713           enddo
1714         enddo
1715       enddo
1716       endif
1717       return
1718       end
1719 C--------------------------------------------------------------------------
1720       subroutine set_matrices
1721       implicit real*8 (a-h,o-z)
1722       include 'DIMENSIONS'
1723 #ifdef MPI
1724       include "mpif.h"
1725       integer IERR
1726       integer status(MPI_STATUS_SIZE)
1727 #endif
1728       include 'DIMENSIONS.ZSCOPT'
1729       include 'COMMON.IOUNITS'
1730       include 'COMMON.GEO'
1731       include 'COMMON.VAR'
1732       include 'COMMON.LOCAL'
1733       include 'COMMON.CHAIN'
1734       include 'COMMON.DERIV'
1735       include 'COMMON.INTERACT'
1736       include 'COMMON.CORRMAT'
1737       include 'COMMON.TORSION'
1738       include 'COMMON.VECTORS'
1739       include 'COMMON.FFIELD'
1740       double precision auxvec(2),auxmat(2,2)
1741 C
1742 C Compute the virtual-bond-torsional-angle dependent quantities needed
1743 C to calculate the el-loc multibody terms of various order.
1744 C
1745 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1746       do i=3,nres+1
1747         ii=ireschain(i-2)
1748         if (ii.eq.0) cycle
1749         innt=chain_border(1,ii)
1750         inct=chain_border(2,ii)
1751 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1752         if (i.gt. innt+2 .and. i.lt.inct+2) then
1753           iti = itype2loc(itype(i-2))
1754         else
1755           iti=nloctyp
1756         endif
1757 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1758 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1759         if (i.gt. innt+1 .and. i.lt.inct+1) then
1760           iti1 = itype2loc(itype(i-1))
1761         else
1762           iti1=nloctyp
1763         endif
1764 #ifdef NEWCORR
1765         cost1=dcos(theta(i-1))
1766         sint1=dsin(theta(i-1))
1767         sint1sq=sint1*sint1
1768         sint1cub=sint1sq*sint1
1769         sint1cost1=2*sint1*cost1
1770 #ifdef DEBUG
1771         write (iout,*) "bnew1",i,iti
1772         write (iout,*) (bnew1(k,1,iti),k=1,3)
1773         write (iout,*) (bnew1(k,2,iti),k=1,3)
1774         write (iout,*) "bnew2",i,iti
1775         write (iout,*) (bnew2(k,1,iti),k=1,3)
1776         write (iout,*) (bnew2(k,2,iti),k=1,3)
1777 #endif
1778         do k=1,2
1779           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1780           b1(k,i-2)=sint1*b1k
1781           gtb1(k,i-2)=cost1*b1k-sint1sq*
1782      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1783           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1784           b2(k,i-2)=sint1*b2k
1785           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1786      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1787         enddo
1788         do k=1,2
1789           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1790           cc(1,k,i-2)=sint1sq*aux
1791           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1792      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1793           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1794           dd(1,k,i-2)=sint1sq*aux
1795           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1796      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1797         enddo
1798         cc(2,1,i-2)=cc(1,2,i-2)
1799         cc(2,2,i-2)=-cc(1,1,i-2)
1800         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1801         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1802         dd(2,1,i-2)=dd(1,2,i-2)
1803         dd(2,2,i-2)=-dd(1,1,i-2)
1804         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1805         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1806         do k=1,2
1807           do l=1,2
1808             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1809             EE(l,k,i-2)=sint1sq*aux
1810             if (calc_grad)
1811      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1812           enddo
1813         enddo
1814         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1815         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1816         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1817         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1818         if (calc_grad) then
1819         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1820         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1821         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1822         endif
1823 c        b1tilde(1,i-2)=b1(1,i-2)
1824 c        b1tilde(2,i-2)=-b1(2,i-2)
1825 c        b2tilde(1,i-2)=b2(1,i-2)
1826 c        b2tilde(2,i-2)=-b2(2,i-2)
1827 #ifdef DEBUG
1828         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1829         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1830         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1831         write (iout,*) 'theta=', theta(i-1)
1832 #endif
1833 #else
1834 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1835 c          iti = itype2loc(itype(i-2))
1836 c        else
1837 c          iti=nloctyp
1838 c        endif
1839 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1840 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1841 c          iti1 = itype2loc(itype(i-1))
1842 c        else
1843 c          iti1=nloctyp
1844 c        endif
1845         b1(1,i-2)=b(3,iti)
1846         b1(2,i-2)=b(5,iti)
1847         b2(1,i-2)=b(2,iti)
1848         b2(2,i-2)=b(4,iti)
1849         do k=1,2
1850           do l=1,2
1851            CC(k,l,i-2)=ccold(k,l,iti)
1852            DD(k,l,i-2)=ddold(k,l,iti)
1853            EE(k,l,i-2)=eeold(k,l,iti)
1854           enddo
1855         enddo
1856 #endif
1857         b1tilde(1,i-2)= b1(1,i-2)
1858         b1tilde(2,i-2)=-b1(2,i-2)
1859         b2tilde(1,i-2)= b2(1,i-2)
1860         b2tilde(2,i-2)=-b2(2,i-2)
1861 c
1862         Ctilde(1,1,i-2)= CC(1,1,i-2)
1863         Ctilde(1,2,i-2)= CC(1,2,i-2)
1864         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1865         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1866 c
1867         Dtilde(1,1,i-2)= DD(1,1,i-2)
1868         Dtilde(1,2,i-2)= DD(1,2,i-2)
1869         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1870         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1871 #ifdef DEBUG
1872         write(iout,*) "i",i," iti",iti
1873         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1874         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1875 #endif
1876       enddo
1877       do i=3,nres+1
1878         if (i .lt. nres+1) then
1879           sin1=dsin(phi(i))
1880           cos1=dcos(phi(i))
1881           sintab(i-2)=sin1
1882           costab(i-2)=cos1
1883           obrot(1,i-2)=cos1
1884           obrot(2,i-2)=sin1
1885           sin2=dsin(2*phi(i))
1886           cos2=dcos(2*phi(i))
1887           sintab2(i-2)=sin2
1888           costab2(i-2)=cos2
1889           obrot2(1,i-2)=cos2
1890           obrot2(2,i-2)=sin2
1891           Ug(1,1,i-2)=-cos1
1892           Ug(1,2,i-2)=-sin1
1893           Ug(2,1,i-2)=-sin1
1894           Ug(2,2,i-2)= cos1
1895           Ug2(1,1,i-2)=-cos2
1896           Ug2(1,2,i-2)=-sin2
1897           Ug2(2,1,i-2)=-sin2
1898           Ug2(2,2,i-2)= cos2
1899         else
1900           costab(i-2)=1.0d0
1901           sintab(i-2)=0.0d0
1902           obrot(1,i-2)=1.0d0
1903           obrot(2,i-2)=0.0d0
1904           obrot2(1,i-2)=0.0d0
1905           obrot2(2,i-2)=0.0d0
1906           Ug(1,1,i-2)=1.0d0
1907           Ug(1,2,i-2)=0.0d0
1908           Ug(2,1,i-2)=0.0d0
1909           Ug(2,2,i-2)=1.0d0
1910           Ug2(1,1,i-2)=0.0d0
1911           Ug2(1,2,i-2)=0.0d0
1912           Ug2(2,1,i-2)=0.0d0
1913           Ug2(2,2,i-2)=0.0d0
1914         endif
1915         if (i .gt. 3 .and. i .lt. nres+1) then
1916           obrot_der(1,i-2)=-sin1
1917           obrot_der(2,i-2)= cos1
1918           Ugder(1,1,i-2)= sin1
1919           Ugder(1,2,i-2)=-cos1
1920           Ugder(2,1,i-2)=-cos1
1921           Ugder(2,2,i-2)=-sin1
1922           dwacos2=cos2+cos2
1923           dwasin2=sin2+sin2
1924           obrot2_der(1,i-2)=-dwasin2
1925           obrot2_der(2,i-2)= dwacos2
1926           Ug2der(1,1,i-2)= dwasin2
1927           Ug2der(1,2,i-2)=-dwacos2
1928           Ug2der(2,1,i-2)=-dwacos2
1929           Ug2der(2,2,i-2)=-dwasin2
1930         else
1931           obrot_der(1,i-2)=0.0d0
1932           obrot_der(2,i-2)=0.0d0
1933           Ugder(1,1,i-2)=0.0d0
1934           Ugder(1,2,i-2)=0.0d0
1935           Ugder(2,1,i-2)=0.0d0
1936           Ugder(2,2,i-2)=0.0d0
1937           obrot2_der(1,i-2)=0.0d0
1938           obrot2_der(2,i-2)=0.0d0
1939           Ug2der(1,1,i-2)=0.0d0
1940           Ug2der(1,2,i-2)=0.0d0
1941           Ug2der(2,1,i-2)=0.0d0
1942           Ug2der(2,2,i-2)=0.0d0
1943         endif
1944 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1945         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1946           iti = itype2loc(itype(i-2))
1947         else
1948           iti=nloctyp
1949         endif
1950 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1951         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1952           iti1 = itype2loc(itype(i-1))
1953         else
1954           iti1=nloctyp
1955         endif
1956 cd        write (iout,*) '*******i',i,' iti1',iti
1957 cd        write (iout,*) 'b1',b1(:,iti)
1958 cd        write (iout,*) 'b2',b2(:,iti)
1959 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1960 c        if (i .gt. iatel_s+2) then
1961         if (i .gt. nnt+2) then
1962           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1963 #ifdef NEWCORR
1964           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1965 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1966 #endif
1967 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1968 c     &    EE(1,2,iti),EE(2,2,i)
1969           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1970           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1971 c          write(iout,*) "Macierz EUG",
1972 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1973 c     &    eug(2,2,i-2)
1974 #ifdef FOURBODY
1975           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1976      &    then
1977           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1978           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1979           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1980           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1981           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1982           endif
1983 #endif
1984         else
1985           do k=1,2
1986             Ub2(k,i-2)=0.0d0
1987             Ctobr(k,i-2)=0.0d0
1988             Dtobr2(k,i-2)=0.0d0
1989             do l=1,2
1990               EUg(l,k,i-2)=0.0d0
1991               CUg(l,k,i-2)=0.0d0
1992               DUg(l,k,i-2)=0.0d0
1993               DtUg2(l,k,i-2)=0.0d0
1994             enddo
1995           enddo
1996         endif
1997         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1998         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1999         do k=1,2
2000           muder(k,i-2)=Ub2der(k,i-2)
2001         enddo
2002 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2003         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2004           if (itype(i-1).le.ntyp) then
2005             iti1 = itype2loc(itype(i-1))
2006           else
2007             iti1=nloctyp
2008           endif
2009         else
2010           iti1=nloctyp
2011         endif
2012         do k=1,2
2013           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2014         enddo
2015 #ifdef MUOUT
2016         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2017      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2018      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2019      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2020      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2021      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2022 #endif
2023 cd        write (iout,*) 'mu1',mu1(:,i-2)
2024 cd        write (iout,*) 'mu2',mu2(:,i-2)
2025 #ifdef FOURBODY
2026         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2027      &  then
2028         if (calc_grad) then
2029         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2030         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2031         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2032         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2033         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2034         endif
2035 C Vectors and matrices dependent on a single virtual-bond dihedral.
2036         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2037         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2038         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2039         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2040         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2041         if (calc_grad) then
2042         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2043         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2044         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2045         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2046         endif
2047         endif
2048 #endif
2049       enddo
2050 #ifdef FOURBODY
2051 C Matrices dependent on two consecutive virtual-bond dihedrals.
2052 C The order of matrices is from left to right.
2053       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2054      &then
2055       do i=2,nres-1
2056         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2057         if (calc_grad) then
2058         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2059         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2060         endif
2061         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2062         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2063         if (calc_grad) then
2064         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2065         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2066         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2067         endif
2068       enddo
2069       endif
2070 #endif
2071       return
2072       end
2073 C--------------------------------------------------------------------------
2074       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2075 C
2076 C This subroutine calculates the average interaction energy and its gradient
2077 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2078 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2079 C The potential depends both on the distance of peptide-group centers and on
2080 C the orientation of the CA-CA virtual bonds.
2081 C
2082       implicit real*8 (a-h,o-z)
2083 #ifdef MPI
2084       include 'mpif.h'
2085 #endif
2086       include 'DIMENSIONS'
2087       include 'DIMENSIONS.ZSCOPT'
2088       include 'COMMON.CONTROL'
2089       include 'COMMON.IOUNITS'
2090       include 'COMMON.GEO'
2091       include 'COMMON.VAR'
2092       include 'COMMON.LOCAL'
2093       include 'COMMON.CHAIN'
2094       include 'COMMON.DERIV'
2095       include 'COMMON.INTERACT'
2096 #ifdef FOURBODY
2097       include 'COMMON.CONTACTS'
2098       include 'COMMON.CONTMAT'
2099 #endif
2100       include 'COMMON.CORRMAT'
2101       include 'COMMON.TORSION'
2102       include 'COMMON.VECTORS'
2103       include 'COMMON.FFIELD'
2104       include 'COMMON.TIME1'
2105       include 'COMMON.SPLITELE'
2106       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2107      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2108       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2109      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2110       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2111      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2112      &    num_conti,j1,j2
2113 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2114 #ifdef MOMENT
2115       double precision scal_el /1.0d0/
2116 #else
2117       double precision scal_el /0.5d0/
2118 #endif
2119 C 12/13/98
2120 C 13-go grudnia roku pamietnego...
2121       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2122      &                   0.0d0,1.0d0,0.0d0,
2123      &                   0.0d0,0.0d0,1.0d0/
2124 cd      write(iout,*) 'In EELEC'
2125 cd      do i=1,nloctyp
2126 cd        write(iout,*) 'Type',i
2127 cd        write(iout,*) 'B1',B1(:,i)
2128 cd        write(iout,*) 'B2',B2(:,i)
2129 cd        write(iout,*) 'CC',CC(:,:,i)
2130 cd        write(iout,*) 'DD',DD(:,:,i)
2131 cd        write(iout,*) 'EE',EE(:,:,i)
2132 cd      enddo
2133 cd      call check_vecgrad
2134 cd      stop
2135       if (icheckgrad.eq.1) then
2136         do i=1,nres-1
2137           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2138           do k=1,3
2139             dc_norm(k,i)=dc(k,i)*fac
2140           enddo
2141 c          write (iout,*) 'i',i,' fac',fac
2142         enddo
2143       endif
2144       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2145      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2146      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2147 c        call vec_and_deriv
2148 #ifdef TIMING
2149         time01=MPI_Wtime()
2150 #endif
2151         call set_matrices
2152 #ifdef TIMING
2153         time_mat=time_mat+MPI_Wtime()-time01
2154 #endif
2155       endif
2156 cd      do i=1,nres-1
2157 cd        write (iout,*) 'i=',i
2158 cd        do k=1,3
2159 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2160 cd        enddo
2161 cd        do k=1,3
2162 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2163 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2164 cd        enddo
2165 cd      enddo
2166       t_eelecij=0.0d0
2167       ees=0.0D0
2168       evdw1=0.0D0
2169       eel_loc=0.0d0
2170       eello_turn3=0.0d0
2171       eello_turn4=0.0d0
2172       ind=0
2173 #ifdef FOURBODY
2174       do i=1,nres
2175         num_cont_hb(i)=0
2176       enddo
2177 #endif
2178 cd      print '(a)','Enter EELEC'
2179 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2180       do i=1,nres
2181         gel_loc_loc(i)=0.0d0
2182         gcorr_loc(i)=0.0d0
2183       enddo
2184 c
2185 c
2186 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2187 C
2188 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2189 C
2190 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2191       do i=iturn3_start,iturn3_end
2192 c        if (i.le.1) cycle
2193 C        write(iout,*) "tu jest i",i
2194         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2195 C changes suggested by Ana to avoid out of bounds
2196 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2197 c     & .or.((i+4).gt.nres)
2198 c     & .or.((i-1).le.0)
2199 C end of changes by Ana
2200 C dobra zmiana wycofana
2201      &  .or. itype(i+2).eq.ntyp1
2202      &  .or. itype(i+3).eq.ntyp1) cycle
2203 C Adam: Instructions below will switch off existing interactions
2204 c        if(i.gt.1)then
2205 c          if(itype(i-1).eq.ntyp1)cycle
2206 c        end if
2207 c        if(i.LT.nres-3)then
2208 c          if (itype(i+4).eq.ntyp1) cycle
2209 c        end if
2210         dxi=dc(1,i)
2211         dyi=dc(2,i)
2212         dzi=dc(3,i)
2213         dx_normi=dc_norm(1,i)
2214         dy_normi=dc_norm(2,i)
2215         dz_normi=dc_norm(3,i)
2216         xmedi=c(1,i)+0.5d0*dxi
2217         ymedi=c(2,i)+0.5d0*dyi
2218         zmedi=c(3,i)+0.5d0*dzi
2219         call to_box(xmedi,ymedi,zmedi)
2220         num_conti=0
2221         call eelecij(i,i+2,ees,evdw1,eel_loc)
2222         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2223 #ifdef FOURBODY
2224         num_cont_hb(i)=num_conti
2225 #endif
2226       enddo
2227       do i=iturn4_start,iturn4_end
2228         if (i.lt.1) cycle
2229         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2230 C changes suggested by Ana to avoid out of bounds
2231 c     & .or.((i+5).gt.nres)
2232 c     & .or.((i-1).le.0)
2233 C end of changes suggested by Ana
2234      &    .or. itype(i+3).eq.ntyp1
2235      &    .or. itype(i+4).eq.ntyp1
2236 c     &    .or. itype(i+5).eq.ntyp1
2237 c     &    .or. itype(i).eq.ntyp1
2238 c     &    .or. itype(i-1).eq.ntyp1
2239      &                             ) cycle
2240         dxi=dc(1,i)
2241         dyi=dc(2,i)
2242         dzi=dc(3,i)
2243         dx_normi=dc_norm(1,i)
2244         dy_normi=dc_norm(2,i)
2245         dz_normi=dc_norm(3,i)
2246         xmedi=c(1,i)+0.5d0*dxi
2247         ymedi=c(2,i)+0.5d0*dyi
2248         zmedi=c(3,i)+0.5d0*dzi
2249         call to_box(xmedi,ymedi,zmedi)
2250 #ifdef FOURBODY
2251         num_conti=num_cont_hb(i)
2252 #endif
2253 c        write(iout,*) "JESTEM W PETLI"
2254         call eelecij(i,i+3,ees,evdw1,eel_loc)
2255         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2256      &   call eturn4(i,eello_turn4)
2257 #ifdef FOURBODY
2258         num_cont_hb(i)=num_conti
2259 #endif
2260       enddo   ! i
2261 C Loop over all neighbouring boxes
2262 C      do xshift=-1,1
2263 C      do yshift=-1,1
2264 C      do zshift=-1,1
2265 c
2266 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2267 c
2268 CTU KURWA
2269       do i=iatel_s,iatel_e
2270 C        do i=75,75
2271 c        if (i.le.1) cycle
2272         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2273 C changes suggested by Ana to avoid out of bounds
2274 c     & .or.((i+2).gt.nres)
2275 c     & .or.((i-1).le.0)
2276 C end of changes by Ana
2277 c     &  .or. itype(i+2).eq.ntyp1
2278 c     &  .or. itype(i-1).eq.ntyp1
2279      &                ) cycle
2280         dxi=dc(1,i)
2281         dyi=dc(2,i)
2282         dzi=dc(3,i)
2283         dx_normi=dc_norm(1,i)
2284         dy_normi=dc_norm(2,i)
2285         dz_normi=dc_norm(3,i)
2286         xmedi=c(1,i)+0.5d0*dxi
2287         ymedi=c(2,i)+0.5d0*dyi
2288         zmedi=c(3,i)+0.5d0*dzi
2289         call to_box(xmedi,ymedi,zmedi)
2290 #ifdef FOURBODY
2291         num_conti=num_cont_hb(i)
2292 #endif
2293 C I TU KURWA
2294         do j=ielstart(i),ielend(i)
2295 C          do j=16,17
2296 C          write (iout,*) i,j
2297 C         if (j.le.1) cycle
2298           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2299 C changes suggested by Ana to avoid out of bounds
2300 c     & .or.((j+2).gt.nres)
2301 c     & .or.((j-1).le.0)
2302 C end of changes by Ana
2303 c     & .or.itype(j+2).eq.ntyp1
2304 c     & .or.itype(j-1).eq.ntyp1
2305      &) cycle
2306           call eelecij(i,j,ees,evdw1,eel_loc)
2307         enddo ! j
2308 #ifdef FOURBODY
2309         num_cont_hb(i)=num_conti
2310 #endif
2311       enddo   ! i
2312 C     enddo   ! zshift
2313 C      enddo   ! yshift
2314 C      enddo   ! xshift
2315
2316 c      write (iout,*) "Number of loop steps in EELEC:",ind
2317 cd      do i=1,nres
2318 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2319 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2320 cd      enddo
2321 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2322 ccc      eel_loc=eel_loc+eello_turn3
2323 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2324       return
2325       end
2326 C-------------------------------------------------------------------------------
2327       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2328       implicit real*8 (a-h,o-z)
2329       include 'DIMENSIONS'
2330       include 'DIMENSIONS.ZSCOPT'
2331 #ifdef MPI
2332       include "mpif.h"
2333 #endif
2334       include 'COMMON.CONTROL'
2335       include 'COMMON.IOUNITS'
2336       include 'COMMON.GEO'
2337       include 'COMMON.VAR'
2338       include 'COMMON.LOCAL'
2339       include 'COMMON.CHAIN'
2340       include 'COMMON.DERIV'
2341       include 'COMMON.INTERACT'
2342 #ifdef FOURBODY
2343       include 'COMMON.CONTACTS'
2344       include 'COMMON.CONTMAT'
2345 #endif
2346       include 'COMMON.CORRMAT'
2347       include 'COMMON.TORSION'
2348       include 'COMMON.VECTORS'
2349       include 'COMMON.FFIELD'
2350       include 'COMMON.TIME1'
2351       include 'COMMON.SPLITELE'
2352       include 'COMMON.SHIELD'
2353       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2354      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2355       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2356      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2357      &    gmuij2(4),gmuji2(4)
2358       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2359      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2360      &    num_conti,j1,j2
2361 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2362 #ifdef MOMENT
2363       double precision scal_el /1.0d0/
2364 #else
2365       double precision scal_el /0.5d0/
2366 #endif
2367 C 12/13/98
2368 C 13-go grudnia roku pamietnego...
2369       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2370      &                   0.0d0,1.0d0,0.0d0,
2371      &                   0.0d0,0.0d0,1.0d0/
2372        integer xshift,yshift,zshift
2373 c          time00=MPI_Wtime()
2374 cd      write (iout,*) "eelecij",i,j
2375 c          ind=ind+1
2376           iteli=itel(i)
2377           itelj=itel(j)
2378           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2379           aaa=app(iteli,itelj)
2380           bbb=bpp(iteli,itelj)
2381           ael6i=ael6(iteli,itelj)
2382           ael3i=ael3(iteli,itelj)
2383           dxj=dc(1,j)
2384           dyj=dc(2,j)
2385           dzj=dc(3,j)
2386           dx_normj=dc_norm(1,j)
2387           dy_normj=dc_norm(2,j)
2388           dz_normj=dc_norm(3,j)
2389 C          xj=c(1,j)+0.5D0*dxj-xmedi
2390 C          yj=c(2,j)+0.5D0*dyj-ymedi
2391 C          zj=c(3,j)+0.5D0*dzj-zmedi
2392           xj=c(1,j)+0.5D0*dxj
2393           yj=c(2,j)+0.5D0*dyj
2394           zj=c(3,j)+0.5D0*dzj
2395           call to_box(xj,yj,zj)
2396           xj=boxshift(xj-xmedi,boxxsize)
2397           yj=boxshift(yj-ymedi,boxysize)
2398           zj=boxshift(zj-zmedi,boxzsize)
2399           rij=xj*xj+yj*yj+zj*zj
2400
2401           sss=sscale(sqrt(rij))
2402           if (sss.eq.0.0d0) return
2403           sssgrad=sscagrad(sqrt(rij))
2404 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2405 c     &       " rlamb",rlamb," sss",sss
2406 c            if (sss.gt.0.0d0) then
2407           rrmij=1.0D0/rij
2408           rij=dsqrt(rij)
2409           rmij=1.0D0/rij
2410           r3ij=rrmij*rmij
2411           r6ij=r3ij*r3ij
2412           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2413           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2414           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2415           fac=cosa-3.0D0*cosb*cosg
2416           ev1=aaa*r6ij*r6ij
2417 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2418           if (j.eq.i+2) ev1=scal_el*ev1
2419           ev2=bbb*r6ij
2420           fac3=ael6i*r6ij
2421           fac4=ael3i*r3ij
2422           evdwij=(ev1+ev2)
2423           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2424           el2=fac4*fac
2425 C MARYSIA
2426 C          eesij=(el1+el2)
2427 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2428           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2429           if (shield_mode.gt.0) then
2430 C          fac_shield(i)=0.4
2431 C          fac_shield(j)=0.6
2432           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2433           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2434           eesij=(el1+el2)
2435           ees=ees+eesij
2436           else
2437           fac_shield(i)=1.0
2438           fac_shield(j)=1.0
2439           eesij=(el1+el2)
2440           ees=ees+eesij
2441           endif
2442           evdw1=evdw1+evdwij*sss
2443 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2444 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2445 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2446 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2447
2448           if (energy_dec) then
2449               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2450      &'evdw1',i,j,evdwij
2451      &,iteli,itelj,aaa,evdw1,sss
2452               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2453      &fac_shield(i),fac_shield(j)
2454           endif
2455
2456 C
2457 C Calculate contributions to the Cartesian gradient.
2458 C
2459 #ifdef SPLITELE
2460           facvdw=-6*rrmij*(ev1+evdwij)*sss
2461           facel=-3*rrmij*(el1+eesij)
2462           fac1=fac
2463           erij(1)=xj*rmij
2464           erij(2)=yj*rmij
2465           erij(3)=zj*rmij
2466
2467 *
2468 * Radial derivatives. First process both termini of the fragment (i,j)
2469 *
2470           if (calc_grad) then
2471           ggg(1)=facel*xj
2472           ggg(2)=facel*yj
2473           ggg(3)=facel*zj
2474           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2475      &  (shield_mode.gt.0)) then
2476 C          print *,i,j
2477           do ilist=1,ishield_list(i)
2478            iresshield=shield_list(ilist,i)
2479            do k=1,3
2480            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2481      &      *2.0
2482            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2483      &              rlocshield
2484      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2485             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2486 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2487 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2488 C             if (iresshield.gt.i) then
2489 C               do ishi=i+1,iresshield-1
2490 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2491 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2492 C
2493 C              enddo
2494 C             else
2495 C               do ishi=iresshield,i
2496 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2497 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2498 C
2499 C               enddo
2500 C              endif
2501            enddo
2502           enddo
2503           do ilist=1,ishield_list(j)
2504            iresshield=shield_list(ilist,j)
2505            do k=1,3
2506            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2507      &     *2.0
2508            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2509      &              rlocshield
2510      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2511            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2512
2513 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2514 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2515 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2516 C             if (iresshield.gt.j) then
2517 C               do ishi=j+1,iresshield-1
2518 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2519 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2520 C
2521 C               enddo
2522 C            else
2523 C               do ishi=iresshield,j
2524 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2525 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2526 C               enddo
2527 C              endif
2528            enddo
2529           enddo
2530
2531           do k=1,3
2532             gshieldc(k,i)=gshieldc(k,i)+
2533      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2534             gshieldc(k,j)=gshieldc(k,j)+
2535      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2536             gshieldc(k,i-1)=gshieldc(k,i-1)+
2537      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2538             gshieldc(k,j-1)=gshieldc(k,j-1)+
2539      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2540
2541            enddo
2542            endif
2543 c          do k=1,3
2544 c            ghalf=0.5D0*ggg(k)
2545 c            gelc(k,i)=gelc(k,i)+ghalf
2546 c            gelc(k,j)=gelc(k,j)+ghalf
2547 c          enddo
2548 c 9/28/08 AL Gradient compotents will be summed only at the end
2549 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2550           do k=1,3
2551             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2552 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2553             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2554 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2555 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2556 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2557 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2558 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2559           enddo
2560 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2561
2562 *
2563 * Loop over residues i+1 thru j-1.
2564 *
2565 cgrad          do k=i+1,j-1
2566 cgrad            do l=1,3
2567 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2568 cgrad            enddo
2569 cgrad          enddo
2570           if (sss.gt.0.0) then
2571           facvdw=facvdw+sssgrad*rmij*evdwij
2572           ggg(1)=facvdw*xj
2573           ggg(2)=facvdw*yj
2574           ggg(3)=facvdw*zj
2575           else
2576           ggg(1)=0.0
2577           ggg(2)=0.0
2578           ggg(3)=0.0
2579           endif
2580 c          do k=1,3
2581 c            ghalf=0.5D0*ggg(k)
2582 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2583 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2584 c          enddo
2585 c 9/28/08 AL Gradient compotents will be summed only at the end
2586           do k=1,3
2587             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2588             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2589           enddo
2590 *
2591 * Loop over residues i+1 thru j-1.
2592 *
2593 cgrad          do k=i+1,j-1
2594 cgrad            do l=1,3
2595 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2596 cgrad            enddo
2597 cgrad          enddo
2598           endif ! calc_grad
2599 #else
2600 C MARYSIA
2601           facvdw=(ev1+evdwij)
2602           facel=(el1+eesij)
2603           fac1=fac
2604           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2605      &       +(evdwij+eesij)*sssgrad*rrmij
2606           erij(1)=xj*rmij
2607           erij(2)=yj*rmij
2608           erij(3)=zj*rmij
2609 *
2610 * Radial derivatives. First process both termini of the fragment (i,j)
2611 *
2612           if (calc_grad) then
2613           ggg(1)=fac*xj
2614 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2615           ggg(2)=fac*yj
2616 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2617           ggg(3)=fac*zj
2618 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2619 c          do k=1,3
2620 c            ghalf=0.5D0*ggg(k)
2621 c            gelc(k,i)=gelc(k,i)+ghalf
2622 c            gelc(k,j)=gelc(k,j)+ghalf
2623 c          enddo
2624 c 9/28/08 AL Gradient compotents will be summed only at the end
2625           do k=1,3
2626             gelc_long(k,j)=gelc(k,j)+ggg(k)
2627             gelc_long(k,i)=gelc(k,i)-ggg(k)
2628           enddo
2629 *
2630 * Loop over residues i+1 thru j-1.
2631 *
2632 cgrad          do k=i+1,j-1
2633 cgrad            do l=1,3
2634 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2635 cgrad            enddo
2636 cgrad          enddo
2637 c 9/28/08 AL Gradient compotents will be summed only at the end
2638           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2639           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2640           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2641           do k=1,3
2642             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2643             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2644           enddo
2645           endif ! calc_grad
2646 #endif
2647 *
2648 * Angular part
2649 *
2650           if (calc_grad) then
2651           ecosa=2.0D0*fac3*fac1+fac4
2652           fac4=-3.0D0*fac4
2653           fac3=-6.0D0*fac3
2654           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2655           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2656           do k=1,3
2657             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2658             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2659           enddo
2660 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2661 cd   &          (dcosg(k),k=1,3)
2662           do k=1,3
2663             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2664      &      fac_shield(i)**2*fac_shield(j)**2
2665           enddo
2666 c          do k=1,3
2667 c            ghalf=0.5D0*ggg(k)
2668 c            gelc(k,i)=gelc(k,i)+ghalf
2669 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2670 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2671 c            gelc(k,j)=gelc(k,j)+ghalf
2672 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2673 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2674 c          enddo
2675 cgrad          do k=i+1,j-1
2676 cgrad            do l=1,3
2677 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2678 cgrad            enddo
2679 cgrad          enddo
2680 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2681           do k=1,3
2682             gelc(k,i)=gelc(k,i)
2683      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2684      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2685      &           *fac_shield(i)**2*fac_shield(j)**2
2686             gelc(k,j)=gelc(k,j)
2687      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2688      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2689      &           *fac_shield(i)**2*fac_shield(j)**2
2690             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2691             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2692           enddo
2693 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2694
2695 C MARYSIA
2696 c          endif !sscale
2697           endif ! calc_grad
2698           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2699      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2700      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2701 C
2702 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2703 C   energy of a peptide unit is assumed in the form of a second-order
2704 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2705 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2706 C   are computed for EVERY pair of non-contiguous peptide groups.
2707 C
2708
2709           if (j.lt.nres-1) then
2710             j1=j+1
2711             j2=j-1
2712           else
2713             j1=j-1
2714             j2=j-2
2715           endif
2716           kkk=0
2717           lll=0
2718           do k=1,2
2719             do l=1,2
2720               kkk=kkk+1
2721               muij(kkk)=mu(k,i)*mu(l,j)
2722 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2723 #ifdef NEWCORR
2724              if (calc_grad) then
2725              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2726 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2727              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2728              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2729 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2730              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2731              endif
2732 #endif
2733             enddo
2734           enddo
2735 #ifdef DEBUG
2736           write (iout,*) 'EELEC: i',i,' j',j
2737           write (iout,*) 'j',j,' j1',j1,' j2',j2
2738           write(iout,*) 'muij',muij
2739           write (iout,*) "uy",uy(:,i)
2740           write (iout,*) "uz",uz(:,j)
2741           write (iout,*) "erij",erij
2742 #endif
2743           ury=scalar(uy(1,i),erij)
2744           urz=scalar(uz(1,i),erij)
2745           vry=scalar(uy(1,j),erij)
2746           vrz=scalar(uz(1,j),erij)
2747           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2748           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2749           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2750           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2751           fac=dsqrt(-ael6i)*r3ij
2752           a22=a22*fac
2753           a23=a23*fac
2754           a32=a32*fac
2755           a33=a33*fac
2756 cd          write (iout,'(4i5,4f10.5)')
2757 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2758 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2759 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2760 cd     &      uy(:,j),uz(:,j)
2761 cd          write (iout,'(4f10.5)')
2762 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2763 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2764 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2765 cd           write (iout,'(9f10.5/)')
2766 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2767 C Derivatives of the elements of A in virtual-bond vectors
2768           if (calc_grad) then
2769           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2770           do k=1,3
2771             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2772             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2773             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2774             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2775             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2776             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2777             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2778             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2779             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2780             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2781             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2782             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2783           enddo
2784 C Compute radial contributions to the gradient
2785           facr=-3.0d0*rrmij
2786           a22der=a22*facr
2787           a23der=a23*facr
2788           a32der=a32*facr
2789           a33der=a33*facr
2790           agg(1,1)=a22der*xj
2791           agg(2,1)=a22der*yj
2792           agg(3,1)=a22der*zj
2793           agg(1,2)=a23der*xj
2794           agg(2,2)=a23der*yj
2795           agg(3,2)=a23der*zj
2796           agg(1,3)=a32der*xj
2797           agg(2,3)=a32der*yj
2798           agg(3,3)=a32der*zj
2799           agg(1,4)=a33der*xj
2800           agg(2,4)=a33der*yj
2801           agg(3,4)=a33der*zj
2802 C Add the contributions coming from er
2803           fac3=-3.0d0*fac
2804           do k=1,3
2805             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2806             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2807             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2808             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2809           enddo
2810           do k=1,3
2811 C Derivatives in DC(i)
2812 cgrad            ghalf1=0.5d0*agg(k,1)
2813 cgrad            ghalf2=0.5d0*agg(k,2)
2814 cgrad            ghalf3=0.5d0*agg(k,3)
2815 cgrad            ghalf4=0.5d0*agg(k,4)
2816             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2817      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2818             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2819      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2820             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2821      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2822             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2823      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2824 C Derivatives in DC(i+1)
2825             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2826      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2827             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2828      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2829             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2830      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2831             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2832      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2833 C Derivatives in DC(j)
2834             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2835      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2836             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2837      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2838             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2839      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2840             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2841      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2842 C Derivatives in DC(j+1) or DC(nres-1)
2843             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2844      &      -3.0d0*vryg(k,3)*ury)
2845             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2846      &      -3.0d0*vrzg(k,3)*ury)
2847             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2848      &      -3.0d0*vryg(k,3)*urz)
2849             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2850      &      -3.0d0*vrzg(k,3)*urz)
2851 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2852 cgrad              do l=1,4
2853 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2854 cgrad              enddo
2855 cgrad            endif
2856           enddo
2857           endif ! calc_grad
2858           acipa(1,1)=a22
2859           acipa(1,2)=a23
2860           acipa(2,1)=a32
2861           acipa(2,2)=a33
2862           a22=-a22
2863           a23=-a23
2864           if (calc_grad) then
2865           do l=1,2
2866             do k=1,3
2867               agg(k,l)=-agg(k,l)
2868               aggi(k,l)=-aggi(k,l)
2869               aggi1(k,l)=-aggi1(k,l)
2870               aggj(k,l)=-aggj(k,l)
2871               aggj1(k,l)=-aggj1(k,l)
2872             enddo
2873           enddo
2874           endif ! calc_grad
2875           if (j.lt.nres-1) then
2876             a22=-a22
2877             a32=-a32
2878             do l=1,3,2
2879               do k=1,3
2880                 agg(k,l)=-agg(k,l)
2881                 aggi(k,l)=-aggi(k,l)
2882                 aggi1(k,l)=-aggi1(k,l)
2883                 aggj(k,l)=-aggj(k,l)
2884                 aggj1(k,l)=-aggj1(k,l)
2885               enddo
2886             enddo
2887           else
2888             a22=-a22
2889             a23=-a23
2890             a32=-a32
2891             a33=-a33
2892             do l=1,4
2893               do k=1,3
2894                 agg(k,l)=-agg(k,l)
2895                 aggi(k,l)=-aggi(k,l)
2896                 aggi1(k,l)=-aggi1(k,l)
2897                 aggj(k,l)=-aggj(k,l)
2898                 aggj1(k,l)=-aggj1(k,l)
2899               enddo
2900             enddo
2901           endif
2902           ENDIF ! WCORR
2903           IF (wel_loc.gt.0.0d0) THEN
2904 C Contribution to the local-electrostatic energy coming from the i-j pair
2905           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2906      &     +a33*muij(4)
2907 #ifdef DEBUG
2908           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2909      &     " a33",a33
2910           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2911      &     " wel_loc",wel_loc
2912 #endif
2913           if (shield_mode.eq.0) then
2914            fac_shield(i)=1.0
2915            fac_shield(j)=1.0
2916 C          else
2917 C           fac_shield(i)=0.4
2918 C           fac_shield(j)=0.6
2919           endif
2920           eel_loc_ij=eel_loc_ij
2921      &    *fac_shield(i)*fac_shield(j)*sss
2922           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2923      &            'eelloc',i,j,eel_loc_ij
2924 c           if (eel_loc_ij.ne.0)
2925 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2926 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2927
2928           eel_loc=eel_loc+eel_loc_ij
2929 C Now derivative over eel_loc
2930           if (calc_grad) then
2931           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2932      &  (shield_mode.gt.0)) then
2933 C          print *,i,j
2934
2935           do ilist=1,ishield_list(i)
2936            iresshield=shield_list(ilist,i)
2937            do k=1,3
2938            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2939      &                                          /fac_shield(i)
2940 C     &      *2.0
2941            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2942      &              rlocshield
2943      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2944             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2945      &      +rlocshield
2946            enddo
2947           enddo
2948           do ilist=1,ishield_list(j)
2949            iresshield=shield_list(ilist,j)
2950            do k=1,3
2951            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2952      &                                       /fac_shield(j)
2953 C     &     *2.0
2954            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2955      &              rlocshield
2956      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2957            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2958      &             +rlocshield
2959
2960            enddo
2961           enddo
2962
2963           do k=1,3
2964             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2965      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2966             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2967      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2968             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2969      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2970             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2971      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2972            enddo
2973            endif
2974
2975
2976 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
2977 c     &                     ' eel_loc_ij',eel_loc_ij
2978 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2979 C Calculate patrial derivative for theta angle
2980 #ifdef NEWCORR
2981          geel_loc_ij=(a22*gmuij1(1)
2982      &     +a23*gmuij1(2)
2983      &     +a32*gmuij1(3)
2984      &     +a33*gmuij1(4))
2985      &    *fac_shield(i)*fac_shield(j)*sss
2986 c         write(iout,*) "derivative over thatai"
2987 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
2988 c     &   a33*gmuij1(4)
2989          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
2990      &      geel_loc_ij*wel_loc
2991 c         write(iout,*) "derivative over thatai-1"
2992 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
2993 c     &   a33*gmuij2(4)
2994          geel_loc_ij=
2995      &     a22*gmuij2(1)
2996      &     +a23*gmuij2(2)
2997      &     +a32*gmuij2(3)
2998      &     +a33*gmuij2(4)
2999          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3000      &      geel_loc_ij*wel_loc
3001      &    *fac_shield(i)*fac_shield(j)*sss
3002
3003 c  Derivative over j residue
3004          geel_loc_ji=a22*gmuji1(1)
3005      &     +a23*gmuji1(2)
3006      &     +a32*gmuji1(3)
3007      &     +a33*gmuji1(4)
3008 c         write(iout,*) "derivative over thataj"
3009 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3010 c     &   a33*gmuji1(4)
3011
3012         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3013      &      geel_loc_ji*wel_loc
3014      &    *fac_shield(i)*fac_shield(j)
3015
3016          geel_loc_ji=
3017      &     +a22*gmuji2(1)
3018      &     +a23*gmuji2(2)
3019      &     +a32*gmuji2(3)
3020      &     +a33*gmuji2(4)
3021 c         write(iout,*) "derivative over thataj-1"
3022 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3023 c     &   a33*gmuji2(4)
3024          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3025      &      geel_loc_ji*wel_loc
3026      &    *fac_shield(i)*fac_shield(j)*sss
3027 #endif
3028 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3029
3030 C Partial derivatives in virtual-bond dihedral angles gamma
3031           if (i.gt.1)
3032      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3033      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3034      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3035      &    *fac_shield(i)*fac_shield(j)
3036
3037           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3038      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3039      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3040      &    *fac_shield(i)*fac_shield(j)
3041 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3042           aux=eel_loc_ij/sss*sssgrad*rmij
3043           ggg(1)=aux*xj
3044           ggg(2)=aux*yj
3045           ggg(3)=aux*zj
3046           do l=1,3
3047             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3048      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3049      &    *fac_shield(i)*fac_shield(j)*sss
3050             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3051             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3052 cgrad            ghalf=0.5d0*ggg(l)
3053 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3054 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3055           enddo
3056 cgrad          do k=i+1,j2
3057 cgrad            do l=1,3
3058 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3059 cgrad            enddo
3060 cgrad          enddo
3061 C Remaining derivatives of eello
3062           do l=1,3
3063             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3064      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3065      &    *fac_shield(i)*fac_shield(j)
3066
3067             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3068      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3069      &    *fac_shield(i)*fac_shield(j)
3070
3071             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3072      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3073      &    *fac_shield(i)*fac_shield(j)
3074
3075             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3076      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3077      &    *fac_shield(i)*fac_shield(j)
3078
3079           enddo
3080           endif ! calc_grad
3081           ENDIF
3082
3083
3084 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3085 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3086 #ifdef FOURBODY
3087           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3088      &       .and. num_conti.le.maxconts) then
3089 c            write (iout,*) i,j," entered corr"
3090 C
3091 C Calculate the contact function. The ith column of the array JCONT will
3092 C contain the numbers of atoms that make contacts with the atom I (of numbers
3093 C greater than I). The arrays FACONT and GACONT will contain the values of
3094 C the contact function and its derivative.
3095 c           r0ij=1.02D0*rpp(iteli,itelj)
3096 c           r0ij=1.11D0*rpp(iteli,itelj)
3097             r0ij=2.20D0*rpp(iteli,itelj)
3098 c           r0ij=1.55D0*rpp(iteli,itelj)
3099             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3100             if (fcont.gt.0.0D0) then
3101               num_conti=num_conti+1
3102               if (num_conti.gt.maxconts) then
3103                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3104      &                         ' will skip next contacts for this conf.'
3105               else
3106                 jcont_hb(num_conti,i)=j
3107 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3108 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3109                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3110      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3111 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3112 C  terms.
3113                 d_cont(num_conti,i)=rij
3114 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3115 C     --- Electrostatic-interaction matrix ---
3116                 a_chuj(1,1,num_conti,i)=a22
3117                 a_chuj(1,2,num_conti,i)=a23
3118                 a_chuj(2,1,num_conti,i)=a32
3119                 a_chuj(2,2,num_conti,i)=a33
3120 C     --- Gradient of rij
3121                 if (calc_grad) then
3122                 do kkk=1,3
3123                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3124                 enddo
3125                 kkll=0
3126                 do k=1,2
3127                   do l=1,2
3128                     kkll=kkll+1
3129                     do m=1,3
3130                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3131                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3132                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3133                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3134                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3135                     enddo
3136                   enddo
3137                 enddo
3138                 endif ! calc_grad
3139                 ENDIF
3140                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3141 C Calculate contact energies
3142                 cosa4=4.0D0*cosa
3143                 wij=cosa-3.0D0*cosb*cosg
3144                 cosbg1=cosb+cosg
3145                 cosbg2=cosb-cosg
3146 c               fac3=dsqrt(-ael6i)/r0ij**3
3147                 fac3=dsqrt(-ael6i)*r3ij
3148 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3149                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3150                 if (ees0tmp.gt.0) then
3151                   ees0pij=dsqrt(ees0tmp)
3152                 else
3153                   ees0pij=0
3154                 endif
3155 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3156                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3157                 if (ees0tmp.gt.0) then
3158                   ees0mij=dsqrt(ees0tmp)
3159                 else
3160                   ees0mij=0
3161                 endif
3162 c               ees0mij=0.0D0
3163                 if (shield_mode.eq.0) then
3164                 fac_shield(i)=1.0d0
3165                 fac_shield(j)=1.0d0
3166                 else
3167                 ees0plist(num_conti,i)=j
3168 C                fac_shield(i)=0.4d0
3169 C                fac_shield(j)=0.6d0
3170                 endif
3171                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3172      &          *fac_shield(i)*fac_shield(j)
3173                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3174      &          *fac_shield(i)*fac_shield(j)
3175 C Diagnostics. Comment out or remove after debugging!
3176 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3177 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3178 c               ees0m(num_conti,i)=0.0D0
3179 C End diagnostics.
3180 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3181 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3182 C Angular derivatives of the contact function
3183
3184                 ees0pij1=fac3/ees0pij
3185                 ees0mij1=fac3/ees0mij
3186                 fac3p=-3.0D0*fac3*rrmij
3187                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3188                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3189 c               ees0mij1=0.0D0
3190                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3191                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3192                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3193                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3194                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3195                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3196                 ecosap=ecosa1+ecosa2
3197                 ecosbp=ecosb1+ecosb2
3198                 ecosgp=ecosg1+ecosg2
3199                 ecosam=ecosa1-ecosa2
3200                 ecosbm=ecosb1-ecosb2
3201                 ecosgm=ecosg1-ecosg2
3202 C Diagnostics
3203 c               ecosap=ecosa1
3204 c               ecosbp=ecosb1
3205 c               ecosgp=ecosg1
3206 c               ecosam=0.0D0
3207 c               ecosbm=0.0D0
3208 c               ecosgm=0.0D0
3209 C End diagnostics
3210                 facont_hb(num_conti,i)=fcont
3211
3212                 if (calc_grad) then
3213                 fprimcont=fprimcont/rij
3214 cd              facont_hb(num_conti,i)=1.0D0
3215 C Following line is for diagnostics.
3216 cd              fprimcont=0.0D0
3217                 do k=1,3
3218                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3219                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3220                 enddo
3221                 do k=1,3
3222                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3223                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3224                 enddo
3225                 gggp(1)=gggp(1)+ees0pijp*xj
3226      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3227                 gggp(2)=gggp(2)+ees0pijp*yj
3228      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3229                 gggp(3)=gggp(3)+ees0pijp*zj
3230      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3231                 gggm(1)=gggm(1)+ees0mijp*xj
3232      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3233                 gggm(2)=gggm(2)+ees0mijp*yj
3234      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3235                 gggm(3)=gggm(3)+ees0mijp*zj
3236      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3237 C Derivatives due to the contact function
3238                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3239                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3240                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3241                 do k=1,3
3242 c
3243 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3244 c          following the change of gradient-summation algorithm.
3245 c
3246 cgrad                  ghalfp=0.5D0*gggp(k)
3247 cgrad                  ghalfm=0.5D0*gggm(k)
3248                   gacontp_hb1(k,num_conti,i)=!ghalfp
3249      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3250      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3251      &          *fac_shield(i)*fac_shield(j)*sss
3252
3253                   gacontp_hb2(k,num_conti,i)=!ghalfp
3254      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3255      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3256      &          *fac_shield(i)*fac_shield(j)*sss
3257
3258                   gacontp_hb3(k,num_conti,i)=gggp(k)
3259      &          *fac_shield(i)*fac_shield(j)*sss
3260
3261                   gacontm_hb1(k,num_conti,i)=!ghalfm
3262      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3263      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3264      &          *fac_shield(i)*fac_shield(j)*sss
3265
3266                   gacontm_hb2(k,num_conti,i)=!ghalfm
3267      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3268      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3269      &          *fac_shield(i)*fac_shield(j)*sss
3270
3271                   gacontm_hb3(k,num_conti,i)=gggm(k)
3272      &          *fac_shield(i)*fac_shield(j)*sss
3273
3274                 enddo
3275 C Diagnostics. Comment out or remove after debugging!
3276 cdiag           do k=1,3
3277 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3278 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3279 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3280 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3281 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3282 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3283 cdiag           enddo
3284
3285                  endif ! calc_grad
3286
3287               ENDIF ! wcorr
3288               endif  ! num_conti.le.maxconts
3289             endif  ! fcont.gt.0
3290           endif    ! j.gt.i+1
3291 #endif
3292           if (calc_grad) then
3293           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3294             do k=1,4
3295               do l=1,3
3296                 ghalf=0.5d0*agg(l,k)
3297                 aggi(l,k)=aggi(l,k)+ghalf
3298                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3299                 aggj(l,k)=aggj(l,k)+ghalf
3300               enddo
3301             enddo
3302             if (j.eq.nres-1 .and. i.lt.j-2) then
3303               do k=1,4
3304                 do l=1,3
3305                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3306                 enddo
3307               enddo
3308             endif
3309           endif
3310           endif ! calc_grad
3311 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3312       return
3313       end
3314 C-----------------------------------------------------------------------------
3315       subroutine eturn3(i,eello_turn3)
3316 C Third- and fourth-order contributions from turns
3317       implicit real*8 (a-h,o-z)
3318       include 'DIMENSIONS'
3319       include 'DIMENSIONS.ZSCOPT'
3320       include 'COMMON.IOUNITS'
3321       include 'COMMON.GEO'
3322       include 'COMMON.VAR'
3323       include 'COMMON.LOCAL'
3324       include 'COMMON.CHAIN'
3325       include 'COMMON.DERIV'
3326       include 'COMMON.INTERACT'
3327       include 'COMMON.CONTACTS'
3328       include 'COMMON.TORSION'
3329       include 'COMMON.VECTORS'
3330       include 'COMMON.FFIELD'
3331       include 'COMMON.CONTROL'
3332       include 'COMMON.SHIELD'
3333       include 'COMMON.CORRMAT'
3334       dimension ggg(3)
3335       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3336      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3337      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3338      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3339      &  auxgmat2(2,2),auxgmatt2(2,2)
3340       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3341      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3342       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3343      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3344      &    num_conti,j1,j2
3345       j=i+2
3346 c      write (iout,*) "eturn3",i,j,j1,j2
3347       a_temp(1,1)=a22
3348       a_temp(1,2)=a23
3349       a_temp(2,1)=a32
3350       a_temp(2,2)=a33
3351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3352 C
3353 C               Third-order contributions
3354 C
3355 C                 (i+2)o----(i+3)
3356 C                      | |
3357 C                      | |
3358 C                 (i+1)o----i
3359 C
3360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3361 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3362         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3363 c auxalary matices for theta gradient
3364 c auxalary matrix for i+1 and constant i+2
3365         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3366 c auxalary matrix for i+2 and constant i+1
3367         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3368         call transpose2(auxmat(1,1),auxmat1(1,1))
3369         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3370         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3371         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3372         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3373         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3374         if (shield_mode.eq.0) then
3375         fac_shield(i)=1.0
3376         fac_shield(j)=1.0
3377 C        else
3378 C        fac_shield(i)=0.4
3379 C        fac_shield(j)=0.6
3380         endif
3381         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3382      &  *fac_shield(i)*fac_shield(j)
3383         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3384      &  *fac_shield(i)*fac_shield(j)
3385         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3386      &    eello_t3
3387         if (calc_grad) then
3388 C#ifdef NEWCORR
3389 C Derivatives in theta
3390         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3391      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3392      &   *fac_shield(i)*fac_shield(j)
3393         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3394      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3395      &   *fac_shield(i)*fac_shield(j)
3396 C#endif
3397
3398 C Derivatives in shield mode
3399           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3400      &  (shield_mode.gt.0)) then
3401 C          print *,i,j
3402
3403           do ilist=1,ishield_list(i)
3404            iresshield=shield_list(ilist,i)
3405            do k=1,3
3406            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3407 C     &      *2.0
3408            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3409      &              rlocshield
3410      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3411             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3412      &      +rlocshield
3413            enddo
3414           enddo
3415           do ilist=1,ishield_list(j)
3416            iresshield=shield_list(ilist,j)
3417            do k=1,3
3418            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3419 C     &     *2.0
3420            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3421      &              rlocshield
3422      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3423            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3424      &             +rlocshield
3425
3426            enddo
3427           enddo
3428
3429           do k=1,3
3430             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3431      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3432             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3433      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3434             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3435      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3436             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3437      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3438            enddo
3439            endif
3440
3441 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3442 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3443 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3444 cd     &    ' eello_turn3_num',4*eello_turn3_num
3445 C Derivatives in gamma(i)
3446         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3447         call transpose2(auxmat2(1,1),auxmat3(1,1))
3448         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3449         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3450      &   *fac_shield(i)*fac_shield(j)
3451 C Derivatives in gamma(i+1)
3452         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3453         call transpose2(auxmat2(1,1),auxmat3(1,1))
3454         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3455         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3456      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3457      &   *fac_shield(i)*fac_shield(j)
3458 C Cartesian derivatives
3459         do l=1,3
3460 c            ghalf1=0.5d0*agg(l,1)
3461 c            ghalf2=0.5d0*agg(l,2)
3462 c            ghalf3=0.5d0*agg(l,3)
3463 c            ghalf4=0.5d0*agg(l,4)
3464           a_temp(1,1)=aggi(l,1)!+ghalf1
3465           a_temp(1,2)=aggi(l,2)!+ghalf2
3466           a_temp(2,1)=aggi(l,3)!+ghalf3
3467           a_temp(2,2)=aggi(l,4)!+ghalf4
3468           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3469           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3470      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3471      &   *fac_shield(i)*fac_shield(j)
3472
3473           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3474           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3475           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3476           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3477           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3478           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3479      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3480      &   *fac_shield(i)*fac_shield(j)
3481           a_temp(1,1)=aggj(l,1)!+ghalf1
3482           a_temp(1,2)=aggj(l,2)!+ghalf2
3483           a_temp(2,1)=aggj(l,3)!+ghalf3
3484           a_temp(2,2)=aggj(l,4)!+ghalf4
3485           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3486           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3487      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3488      &   *fac_shield(i)*fac_shield(j)
3489           a_temp(1,1)=aggj1(l,1)
3490           a_temp(1,2)=aggj1(l,2)
3491           a_temp(2,1)=aggj1(l,3)
3492           a_temp(2,2)=aggj1(l,4)
3493           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3494           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3495      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3496      &   *fac_shield(i)*fac_shield(j)
3497         enddo
3498
3499         endif ! calc_grad
3500
3501       return
3502       end
3503 C-------------------------------------------------------------------------------
3504       subroutine eturn4(i,eello_turn4)
3505 C Third- and fourth-order contributions from turns
3506       implicit real*8 (a-h,o-z)
3507       include 'DIMENSIONS'
3508       include 'DIMENSIONS.ZSCOPT'
3509       include 'COMMON.IOUNITS'
3510       include 'COMMON.GEO'
3511       include 'COMMON.VAR'
3512       include 'COMMON.LOCAL'
3513       include 'COMMON.CHAIN'
3514       include 'COMMON.DERIV'
3515       include 'COMMON.INTERACT'
3516       include 'COMMON.CONTACTS'
3517       include 'COMMON.TORSION'
3518       include 'COMMON.VECTORS'
3519       include 'COMMON.FFIELD'
3520       include 'COMMON.CONTROL'
3521       include 'COMMON.SHIELD'
3522       include 'COMMON.CORRMAT'
3523       dimension ggg(3)
3524       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3525      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3526      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3527      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3528      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3529      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3530      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3531       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3532      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3533       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3534      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3535      &    num_conti,j1,j2
3536       j=i+3
3537 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3538 C
3539 C               Fourth-order contributions
3540 C
3541 C                 (i+3)o----(i+4)
3542 C                     /  |
3543 C               (i+2)o   |
3544 C                     \  |
3545 C                 (i+1)o----i
3546 C
3547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3548 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3549 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3550 c        write(iout,*)"WCHODZE W PROGRAM"
3551         a_temp(1,1)=a22
3552         a_temp(1,2)=a23
3553         a_temp(2,1)=a32
3554         a_temp(2,2)=a33
3555         iti1=itype2loc(itype(i+1))
3556         iti2=itype2loc(itype(i+2))
3557         iti3=itype2loc(itype(i+3))
3558 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3559         call transpose2(EUg(1,1,i+1),e1t(1,1))
3560         call transpose2(Eug(1,1,i+2),e2t(1,1))
3561         call transpose2(Eug(1,1,i+3),e3t(1,1))
3562 C Ematrix derivative in theta
3563         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3564         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3565         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3566         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3567 c       eta1 in derivative theta
3568         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3569         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3570 c       auxgvec is derivative of Ub2 so i+3 theta
3571         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3572 c       auxalary matrix of E i+1
3573         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3574 c        s1=0.0
3575 c        gs1=0.0
3576         s1=scalar2(b1(1,i+2),auxvec(1))
3577 c derivative of theta i+2 with constant i+3
3578         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3579 c derivative of theta i+2 with constant i+2
3580         gs32=scalar2(b1(1,i+2),auxgvec(1))
3581 c derivative of E matix in theta of i+1
3582         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3583
3584         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3585 c       ea31 in derivative theta
3586         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3587         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3588 c auxilary matrix auxgvec of Ub2 with constant E matirx
3589         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3590 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3591         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3592
3593 c        s2=0.0
3594 c        gs2=0.0
3595         s2=scalar2(b1(1,i+1),auxvec(1))
3596 c derivative of theta i+1 with constant i+3
3597         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3598 c derivative of theta i+2 with constant i+1
3599         gs21=scalar2(b1(1,i+1),auxgvec(1))
3600 c derivative of theta i+3 with constant i+1
3601         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3602 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3603 c     &  gtb1(1,i+1)
3604         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3605 c two derivatives over diffetent matrices
3606 c gtae3e2 is derivative over i+3
3607         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3608 c ae3gte2 is derivative over i+2
3609         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3610         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3611 c three possible derivative over theta E matices
3612 c i+1
3613         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3614 c i+2
3615         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3616 c i+3
3617         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3618         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3619
3620         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3621         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3622         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3623         if (shield_mode.eq.0) then
3624         fac_shield(i)=1.0
3625         fac_shield(j)=1.0
3626 C        else
3627 C        fac_shield(i)=0.6
3628 C        fac_shield(j)=0.4
3629         endif
3630         eello_turn4=eello_turn4-(s1+s2+s3)
3631      &  *fac_shield(i)*fac_shield(j)
3632         eello_t4=-(s1+s2+s3)
3633      &  *fac_shield(i)*fac_shield(j)
3634 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3635         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3636      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3637 C Now derivative over shield:
3638           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3639      &  (shield_mode.gt.0)) then
3640 C          print *,i,j
3641
3642           do ilist=1,ishield_list(i)
3643            iresshield=shield_list(ilist,i)
3644            do k=1,3
3645            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3646 C     &      *2.0
3647            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3648      &              rlocshield
3649      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3650             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3651      &      +rlocshield
3652            enddo
3653           enddo
3654           do ilist=1,ishield_list(j)
3655            iresshield=shield_list(ilist,j)
3656            do k=1,3
3657            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3658 C     &     *2.0
3659            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3660      &              rlocshield
3661      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3662            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3663      &             +rlocshield
3664
3665            enddo
3666           enddo
3667
3668           do k=1,3
3669             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3670      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3671             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3672      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3673             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3674      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3675             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3676      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3677            enddo
3678            endif
3679 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3680 cd     &    ' eello_turn4_num',8*eello_turn4_num
3681 #ifdef NEWCORR
3682         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3683      &                  -(gs13+gsE13+gsEE1)*wturn4
3684      &  *fac_shield(i)*fac_shield(j)
3685         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3686      &                    -(gs23+gs21+gsEE2)*wturn4
3687      &  *fac_shield(i)*fac_shield(j)
3688
3689         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3690      &                    -(gs32+gsE31+gsEE3)*wturn4
3691      &  *fac_shield(i)*fac_shield(j)
3692
3693 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3694 c     &   gs2
3695 #endif
3696         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3697      &      'eturn4',i,j,-(s1+s2+s3)
3698 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3699 c     &    ' eello_turn4_num',8*eello_turn4_num
3700 C Derivatives in gamma(i)
3701         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3702         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3703         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3704         s1=scalar2(b1(1,i+2),auxvec(1))
3705         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3706         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3707         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3708      &  *fac_shield(i)*fac_shield(j)
3709 C Derivatives in gamma(i+1)
3710         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3711         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3712         s2=scalar2(b1(1,i+1),auxvec(1))
3713         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3714         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3715         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3716         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3717      &  *fac_shield(i)*fac_shield(j)
3718 C Derivatives in gamma(i+2)
3719         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3720         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3721         s1=scalar2(b1(1,i+2),auxvec(1))
3722         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3723         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3724         s2=scalar2(b1(1,i+1),auxvec(1))
3725         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3726         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3727         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3729      &  *fac_shield(i)*fac_shield(j)
3730         if (calc_grad) then
3731 C Cartesian derivatives
3732 C Derivatives of this turn contributions in DC(i+2)
3733         if (j.lt.nres-1) then
3734           do l=1,3
3735             a_temp(1,1)=agg(l,1)
3736             a_temp(1,2)=agg(l,2)
3737             a_temp(2,1)=agg(l,3)
3738             a_temp(2,2)=agg(l,4)
3739             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3740             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3741             s1=scalar2(b1(1,i+2),auxvec(1))
3742             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3743             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3744             s2=scalar2(b1(1,i+1),auxvec(1))
3745             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3746             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3747             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3748             ggg(l)=-(s1+s2+s3)
3749             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3750      &  *fac_shield(i)*fac_shield(j)
3751           enddo
3752         endif
3753 C Remaining derivatives of this turn contribution
3754         do l=1,3
3755           a_temp(1,1)=aggi(l,1)
3756           a_temp(1,2)=aggi(l,2)
3757           a_temp(2,1)=aggi(l,3)
3758           a_temp(2,2)=aggi(l,4)
3759           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3760           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3761           s1=scalar2(b1(1,i+2),auxvec(1))
3762           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3763           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3764           s2=scalar2(b1(1,i+1),auxvec(1))
3765           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3766           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3767           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3768           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3769      &  *fac_shield(i)*fac_shield(j)
3770           a_temp(1,1)=aggi1(l,1)
3771           a_temp(1,2)=aggi1(l,2)
3772           a_temp(2,1)=aggi1(l,3)
3773           a_temp(2,2)=aggi1(l,4)
3774           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3775           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3776           s1=scalar2(b1(1,i+2),auxvec(1))
3777           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3778           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3779           s2=scalar2(b1(1,i+1),auxvec(1))
3780           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3781           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3782           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3783           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3784      &  *fac_shield(i)*fac_shield(j)
3785           a_temp(1,1)=aggj(l,1)
3786           a_temp(1,2)=aggj(l,2)
3787           a_temp(2,1)=aggj(l,3)
3788           a_temp(2,2)=aggj(l,4)
3789           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3790           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3791           s1=scalar2(b1(1,i+2),auxvec(1))
3792           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3793           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3794           s2=scalar2(b1(1,i+1),auxvec(1))
3795           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3796           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3797           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3798           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3799      &  *fac_shield(i)*fac_shield(j)
3800           a_temp(1,1)=aggj1(l,1)
3801           a_temp(1,2)=aggj1(l,2)
3802           a_temp(2,1)=aggj1(l,3)
3803           a_temp(2,2)=aggj1(l,4)
3804           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3805           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3806           s1=scalar2(b1(1,i+2),auxvec(1))
3807           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3808           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3809           s2=scalar2(b1(1,i+1),auxvec(1))
3810           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3811           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3812           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3813 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3814           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3815      &  *fac_shield(i)*fac_shield(j)
3816         enddo
3817
3818         endif ! calc_grad
3819
3820       return
3821       end
3822 C-----------------------------------------------------------------------------
3823       subroutine vecpr(u,v,w)
3824       implicit real*8(a-h,o-z)
3825       dimension u(3),v(3),w(3)
3826       w(1)=u(2)*v(3)-u(3)*v(2)
3827       w(2)=-u(1)*v(3)+u(3)*v(1)
3828       w(3)=u(1)*v(2)-u(2)*v(1)
3829       return
3830       end
3831 C-----------------------------------------------------------------------------
3832       subroutine unormderiv(u,ugrad,unorm,ungrad)
3833 C This subroutine computes the derivatives of a normalized vector u, given
3834 C the derivatives computed without normalization conditions, ugrad. Returns
3835 C ungrad.
3836       implicit none
3837       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3838       double precision vec(3)
3839       double precision scalar
3840       integer i,j
3841 c      write (2,*) 'ugrad',ugrad
3842 c      write (2,*) 'u',u
3843       do i=1,3
3844         vec(i)=scalar(ugrad(1,i),u(1))
3845       enddo
3846 c      write (2,*) 'vec',vec
3847       do i=1,3
3848         do j=1,3
3849           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3850         enddo
3851       enddo
3852 c      write (2,*) 'ungrad',ungrad
3853       return
3854       end
3855 C-----------------------------------------------------------------------------
3856       subroutine escp(evdw2,evdw2_14)
3857 C
3858 C This subroutine calculates the excluded-volume interaction energy between
3859 C peptide-group centers and side chains and its gradient in virtual-bond and
3860 C side-chain vectors.
3861 C
3862       implicit real*8 (a-h,o-z)
3863       include 'DIMENSIONS'
3864       include 'DIMENSIONS.ZSCOPT'
3865       include 'COMMON.CONTROL'
3866       include 'COMMON.GEO'
3867       include 'COMMON.VAR'
3868       include 'COMMON.LOCAL'
3869       include 'COMMON.CHAIN'
3870       include 'COMMON.DERIV'
3871       include 'COMMON.INTERACT'
3872       include 'COMMON.FFIELD'
3873       include 'COMMON.IOUNITS'
3874       dimension ggg(3)
3875       evdw2=0.0D0
3876       evdw2_14=0.0d0
3877 cd    print '(a)','Enter ESCP'
3878 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3879 c     &  ' scal14',scal14
3880       do i=iatscp_s,iatscp_e
3881         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3882         iteli=itel(i)
3883 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3884 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3885         if (iteli.eq.0) goto 1225
3886         xi=0.5D0*(c(1,i)+c(1,i+1))
3887         yi=0.5D0*(c(2,i)+c(2,i+1))
3888         zi=0.5D0*(c(3,i)+c(3,i+1))
3889         call to_box(xi,yi,zi)
3890         do iint=1,nscp_gr(i)
3891
3892         do j=iscpstart(i,iint),iscpend(i,iint)
3893           itypj=iabs(itype(j))
3894           if (itypj.eq.ntyp1) cycle
3895 C Uncomment following three lines for SC-p interactions
3896 c         xj=c(1,nres+j)-xi
3897 c         yj=c(2,nres+j)-yi
3898 c         zj=c(3,nres+j)-zi
3899 C Uncomment following three lines for Ca-p interactions
3900           xj=c(1,j)
3901           yj=c(2,j)
3902           zj=c(3,j)
3903 C returning the jth atom to box
3904           call to_box(xj,yj,zj)
3905           xj=boxshift(xj-xi,boxxsize)
3906           yj=boxshift(yj-yi,boxysize)
3907           zj=boxshift(zj-zi,boxzsize)
3908           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3909 C sss is scaling function for smoothing the cutoff gradient otherwise
3910 C the gradient would not be continuouse
3911           sss=sscale(1.0d0/(dsqrt(rrij)))
3912           if (sss.le.0.0d0) cycle
3913           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3914           fac=rrij**expon2
3915           e1=fac*fac*aad(itypj,iteli)
3916           e2=fac*bad(itypj,iteli)
3917           if (iabs(j-i) .le. 2) then
3918             e1=scal14*e1
3919             e2=scal14*e2
3920             evdw2_14=evdw2_14+(e1+e2)*sss
3921           endif
3922           evdwij=e1+e2
3923 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3924 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3925 c     &       bad(itypj,iteli)
3926           evdw2=evdw2+evdwij*sss
3927           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3928      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3929      &       bad(itypj,iteli)
3930
3931           if (calc_grad) then
3932 C
3933 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3934 C
3935           fac=-(evdwij+e1)*rrij*sss
3936           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3937           ggg(1)=xj*fac
3938           ggg(2)=yj*fac
3939           ggg(3)=zj*fac
3940           if (j.lt.i) then
3941 cd          write (iout,*) 'j<i'
3942 C Uncomment following three lines for SC-p interactions
3943 c           do k=1,3
3944 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3945 c           enddo
3946           else
3947 cd          write (iout,*) 'j>i'
3948             do k=1,3
3949               ggg(k)=-ggg(k)
3950 C Uncomment following line for SC-p interactions
3951 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3952             enddo
3953           endif
3954           do k=1,3
3955             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3956           enddo
3957           kstart=min0(i+1,j)
3958           kend=max0(i-1,j-1)
3959 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3960 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3961           do k=kstart,kend
3962             do l=1,3
3963               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3964             enddo
3965           enddo
3966           endif ! calc_grad
3967         enddo
3968         enddo ! iint
3969  1225   continue
3970       enddo ! i
3971       do i=1,nct
3972         do j=1,3
3973           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3974           gradx_scp(j,i)=expon*gradx_scp(j,i)
3975         enddo
3976       enddo
3977 C******************************************************************************
3978 C
3979 C                              N O T E !!!
3980 C
3981 C To save time the factor EXPON has been extracted from ALL components
3982 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3983 C use!
3984 C
3985 C******************************************************************************
3986       return
3987       end
3988 C--------------------------------------------------------------------------
3989       subroutine edis(ehpb)
3990 C
3991 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3992 C
3993       implicit real*8 (a-h,o-z)
3994       include 'DIMENSIONS'
3995       include 'DIMENSIONS.ZSCOPT'
3996       include 'COMMON.SBRIDGE'
3997       include 'COMMON.CHAIN'
3998       include 'COMMON.DERIV'
3999       include 'COMMON.VAR'
4000       include 'COMMON.INTERACT'
4001       include 'COMMON.CONTROL'
4002       include 'COMMON.IOUNITS'
4003       dimension ggg(3),ggg_peak(3,1000)
4004       ehpb=0.0D0
4005       do i=1,3
4006        ggg(i)=0.0d0
4007       enddo
4008 c 8/21/18 AL: added explicit restraints on reference coords
4009 c      write (iout,*) "restr_on_coord",restr_on_coord
4010       if (restr_on_coord) then
4011
4012       do i=nnt,nct
4013         ecoor=0.0d0
4014         if (itype(i).eq.ntyp1) cycle
4015         do j=1,3
4016           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4017           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4018         enddo
4019         if (itype(i).ne.10) then
4020           do j=1,3
4021             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4022             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4023           enddo
4024         endif
4025         if (energy_dec) write (iout,*)
4026      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4027         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4028       enddo
4029
4030       endif
4031
4032 C      write (iout,*) ,"link_end",link_end,constr_dist
4033 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4034 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4035 c     &  " constr_dist",constr_dist
4036       if (link_end.eq.0.and.link_end_peak.eq.0) return
4037       do i=link_start_peak,link_end_peak
4038         ehpb_peak=0.0d0
4039 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4040 c     &   ipeak(1,i),ipeak(2,i)
4041         do ip=ipeak(1,i),ipeak(2,i)
4042           ii=ihpb_peak(ip)
4043           jj=jhpb_peak(ip)
4044           dd=dist(ii,jj)
4045           iip=ip-ipeak(1,i)+1
4046 C iii and jjj point to the residues for which the distance is assigned.
4047 c          if (ii.gt.nres) then
4048 c            iii=ii-nres
4049 c            jjj=jj-nres
4050 c          else
4051 c            iii=ii
4052 c            jjj=jj
4053 c          endif
4054           if (ii.gt.nres) then
4055             iii=ii-nres
4056           else
4057             iii=ii
4058           endif
4059           if (jj.gt.nres) then
4060             jjj=jj-nres
4061           else
4062             jjj=jj
4063           endif
4064           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4065           aux=dexp(-scal_peak*aux)
4066           ehpb_peak=ehpb_peak+aux
4067           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4068      &      forcon_peak(ip))*aux/dd
4069           do j=1,3
4070             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4071           enddo
4072           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4073      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4074      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4075         enddo
4076 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4077         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4078         do ip=ipeak(1,i),ipeak(2,i)
4079           iip=ip-ipeak(1,i)+1
4080           do j=1,3
4081             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4082           enddo
4083           ii=ihpb_peak(ip)
4084           jj=jhpb_peak(ip)
4085 C iii and jjj point to the residues for which the distance is assigned.
4086           if (ii.gt.nres) then
4087             iii=ii-nres
4088             jjj=jj-nres
4089           else
4090             iii=ii
4091             jjj=jj
4092           endif
4093           if (iii.lt.ii) then
4094             do j=1,3
4095               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4096             enddo
4097           endif
4098           if (jjj.lt.jj) then
4099             do j=1,3
4100               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4101             enddo
4102           endif
4103           do k=1,3
4104             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4105             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4106           enddo
4107         enddo
4108       enddo
4109       do i=link_start,link_end
4110 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4111 C CA-CA distance used in regularization of structure.
4112         ii=ihpb(i)
4113         jj=jhpb(i)
4114 C iii and jjj point to the residues for which the distance is assigned.
4115         if (ii.gt.nres) then
4116           iii=ii-nres
4117         else
4118           iii=ii
4119         endif
4120         if (jj.gt.nres) then
4121           jjj=jj-nres
4122         else
4123           jjj=jj
4124         endif
4125 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4126 c     &    dhpb(i),dhpb1(i),forcon(i)
4127 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4128 C    distance and angle dependent SS bond potential.
4129 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4130 C     & iabs(itype(jjj)).eq.1) then
4131 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4132 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4133         if (.not.dyn_ss .and. i.le.nss) then
4134 C 15/02/13 CC dynamic SSbond - additional check
4135           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4136      &        iabs(itype(jjj)).eq.1) then
4137            call ssbond_ene(iii,jjj,eij)
4138            ehpb=ehpb+2*eij
4139          endif
4140 cd          write (iout,*) "eij",eij
4141 cd   &   ' waga=',waga,' fac=',fac
4142 !        else if (ii.gt.nres .and. jj.gt.nres) then
4143         else
4144 C Calculate the distance between the two points and its difference from the
4145 C target distance.
4146           dd=dist(ii,jj)
4147           if (irestr_type(i).eq.11) then
4148             ehpb=ehpb+fordepth(i)!**4.0d0
4149      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4150             fac=fordepth(i)!**4.0d0
4151      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4152             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4153      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4154      &        ehpb,irestr_type(i)
4155           else if (irestr_type(i).eq.10) then
4156 c AL 6//19/2018 cross-link restraints
4157             xdis = 0.5d0*(dd/forcon(i))**2
4158             expdis = dexp(-xdis)
4159 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4160             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4161 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4162 c     &          " wboltzd",wboltzd
4163             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4164 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4165             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4166      &           *expdis/(aux*forcon(i)**2)
4167             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4168      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4169      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4170           else if (irestr_type(i).eq.2) then
4171 c Quartic restraints
4172             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4173             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4174      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4175      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4176             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4177           else
4178 c Quadratic restraints
4179             rdis=dd-dhpb(i)
4180 C Get the force constant corresponding to this distance.
4181             waga=forcon(i)
4182 C Calculate the contribution to energy.
4183             ehpb=ehpb+0.5d0*waga*rdis*rdis
4184             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4185      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4186      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4187 C
4188 C Evaluate gradient.
4189 C
4190             fac=waga*rdis/dd
4191           endif
4192 c Calculate Cartesian gradient
4193           do j=1,3
4194             ggg(j)=fac*(c(j,jj)-c(j,ii))
4195           enddo
4196 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4197 C If this is a SC-SC distance, we need to calculate the contributions to the
4198 C Cartesian gradient in the SC vectors (ghpbx).
4199           if (iii.lt.ii) then
4200             do j=1,3
4201               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4202             enddo
4203           endif
4204           if (jjj.lt.jj) then
4205             do j=1,3
4206               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4207             enddo
4208           endif
4209           do k=1,3
4210             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4211             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4212           enddo
4213         endif
4214       enddo
4215       return
4216       end
4217 C--------------------------------------------------------------------------
4218       subroutine ssbond_ene(i,j,eij)
4219 C
4220 C Calculate the distance and angle dependent SS-bond potential energy
4221 C using a free-energy function derived based on RHF/6-31G** ab initio
4222 C calculations of diethyl disulfide.
4223 C
4224 C A. Liwo and U. Kozlowska, 11/24/03
4225 C
4226       implicit real*8 (a-h,o-z)
4227       include 'DIMENSIONS'
4228       include 'DIMENSIONS.ZSCOPT'
4229       include 'COMMON.SBRIDGE'
4230       include 'COMMON.CHAIN'
4231       include 'COMMON.DERIV'
4232       include 'COMMON.LOCAL'
4233       include 'COMMON.INTERACT'
4234       include 'COMMON.VAR'
4235       include 'COMMON.IOUNITS'
4236       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4237       itypi=iabs(itype(i))
4238       xi=c(1,nres+i)
4239       yi=c(2,nres+i)
4240       zi=c(3,nres+i)
4241       dxi=dc_norm(1,nres+i)
4242       dyi=dc_norm(2,nres+i)
4243       dzi=dc_norm(3,nres+i)
4244       dsci_inv=dsc_inv(itypi)
4245       itypj=iabs(itype(j))
4246       dscj_inv=dsc_inv(itypj)
4247       xj=c(1,nres+j)-xi
4248       yj=c(2,nres+j)-yi
4249       zj=c(3,nres+j)-zi
4250       dxj=dc_norm(1,nres+j)
4251       dyj=dc_norm(2,nres+j)
4252       dzj=dc_norm(3,nres+j)
4253       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4254       rij=dsqrt(rrij)
4255       erij(1)=xj*rij
4256       erij(2)=yj*rij
4257       erij(3)=zj*rij
4258       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4259       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4260       om12=dxi*dxj+dyi*dyj+dzi*dzj
4261       do k=1,3
4262         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4263         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4264       enddo
4265       rij=1.0d0/rij
4266       deltad=rij-d0cm
4267       deltat1=1.0d0-om1
4268       deltat2=1.0d0+om2
4269       deltat12=om2-om1+2.0d0
4270       cosphi=om12-om1*om2
4271       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4272      &  +akct*deltad*deltat12
4273      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4274 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4275 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4276 c     &  " deltat12",deltat12," eij",eij
4277       ed=2*akcm*deltad+akct*deltat12
4278       pom1=akct*deltad
4279       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4280       eom1=-2*akth*deltat1-pom1-om2*pom2
4281       eom2= 2*akth*deltat2+pom1-om1*pom2
4282       eom12=pom2
4283       do k=1,3
4284         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4285       enddo
4286       do k=1,3
4287         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4288      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4289         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4290      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4291       enddo
4292 C
4293 C Calculate the components of the gradient in DC and X
4294 C
4295       do k=i,j-1
4296         do l=1,3
4297           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4298         enddo
4299       enddo
4300       return
4301       end
4302 C--------------------------------------------------------------------------
4303 c MODELLER restraint function
4304       subroutine e_modeller(ehomology_constr)
4305       implicit real*8 (a-h,o-z)
4306       include 'DIMENSIONS'
4307       include 'DIMENSIONS.ZSCOPT'
4308       include 'DIMENSIONS.FREE'
4309       integer nnn, i, j, k, ki, irec, l
4310       integer katy, odleglosci, test7
4311       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4312       real*8 distance(max_template),distancek(max_template),
4313      &    min_odl,godl(max_template),dih_diff(max_template)
4314
4315 c
4316 c     FP - 30/10/2014 Temporary specifications for homology restraints
4317 c
4318       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4319      &                 sgtheta
4320       double precision, dimension (maxres) :: guscdiff,usc_diff
4321       double precision, dimension (max_template) ::
4322      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4323      &           theta_diff
4324
4325       include 'COMMON.SBRIDGE'
4326       include 'COMMON.CHAIN'
4327       include 'COMMON.GEO'
4328       include 'COMMON.DERIV'
4329       include 'COMMON.LOCAL'
4330       include 'COMMON.INTERACT'
4331       include 'COMMON.VAR'
4332       include 'COMMON.IOUNITS'
4333       include 'COMMON.CONTROL'
4334       include 'COMMON.HOMRESTR'
4335       include 'COMMON.HOMOLOGY'
4336       include 'COMMON.SETUP'
4337       include 'COMMON.NAMES'
4338
4339       do i=1,max_template
4340         distancek(i)=9999999.9
4341       enddo
4342
4343       odleg=0.0d0
4344
4345 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4346 c function)
4347 C AL 5/2/14 - Introduce list of restraints
4348 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4349 #ifdef DEBUG
4350       write(iout,*) "------- dist restrs start -------"
4351 #endif
4352       do ii = link_start_homo,link_end_homo
4353          i = ires_homo(ii)
4354          j = jres_homo(ii)
4355          dij=dist(i,j)
4356 c        write (iout,*) "dij(",i,j,") =",dij
4357          nexl=0
4358          do k=1,constr_homology
4359            if(.not.l_homo(k,ii)) then
4360               nexl=nexl+1
4361               cycle
4362            endif
4363            distance(k)=odl(k,ii)-dij
4364 c          write (iout,*) "distance(",k,") =",distance(k)
4365 c
4366 c          For Gaussian-type Urestr
4367 c
4368            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4369 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4370 c          write (iout,*) "distancek(",k,") =",distancek(k)
4371 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4372 c
4373 c          For Lorentzian-type Urestr
4374 c
4375            if (waga_dist.lt.0.0d0) then
4376               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4377               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4378      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4379            endif
4380          enddo
4381
4382 c         min_odl=minval(distancek)
4383          if (nexl.gt.0) then
4384            min_odl=0.0d0
4385          else
4386            do kk=1,constr_homology
4387             if(l_homo(kk,ii)) then
4388               min_odl=distancek(kk)
4389               exit
4390             endif
4391            enddo
4392            do kk=1,constr_homology
4393             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4394      &              min_odl=distancek(kk)
4395            enddo
4396          endif
4397 c        write (iout,* )"min_odl",min_odl
4398 #ifdef DEBUG
4399          write (iout,*) "ij dij",i,j,dij
4400          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4401          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4402          write (iout,* )"min_odl",min_odl
4403 #endif
4404 #ifdef OLDRESTR
4405          odleg2=0.0d0
4406 #else
4407          if (waga_dist.ge.0.0d0) then
4408            odleg2=nexl
4409          else
4410            odleg2=0.0d0
4411          endif
4412 #endif
4413          do k=1,constr_homology
4414 c Nie wiem po co to liczycie jeszcze raz!
4415 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4416 c     &              (2*(sigma_odl(i,j,k))**2))
4417            if(.not.l_homo(k,ii)) cycle
4418            if (waga_dist.ge.0.0d0) then
4419 c
4420 c          For Gaussian-type Urestr
4421 c
4422             godl(k)=dexp(-distancek(k)+min_odl)
4423             odleg2=odleg2+godl(k)
4424 c
4425 c          For Lorentzian-type Urestr
4426 c
4427            else
4428             odleg2=odleg2+distancek(k)
4429            endif
4430
4431 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4432 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4433 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4434 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4435
4436          enddo
4437 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4438 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4439 #ifdef DEBUG
4440          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4441          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4442 #endif
4443            if (waga_dist.ge.0.0d0) then
4444 c
4445 c          For Gaussian-type Urestr
4446 c
4447               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4448 c
4449 c          For Lorentzian-type Urestr
4450 c
4451            else
4452               odleg=odleg+odleg2/constr_homology
4453            endif
4454 c
4455 #ifdef GRAD
4456 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4457 c Gradient
4458 c
4459 c          For Gaussian-type Urestr
4460 c
4461          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4462          sum_sgodl=0.0d0
4463          do k=1,constr_homology
4464 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4465 c     &           *waga_dist)+min_odl
4466 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4467 c
4468          if(.not.l_homo(k,ii)) cycle
4469          if (waga_dist.ge.0.0d0) then
4470 c          For Gaussian-type Urestr
4471 c
4472            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4473 c
4474 c          For Lorentzian-type Urestr
4475 c
4476          else
4477            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4478      &           sigma_odlir(k,ii)**2)**2)
4479          endif
4480            sum_sgodl=sum_sgodl+sgodl
4481
4482 c            sgodl2=sgodl2+sgodl
4483 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4484 c      write(iout,*) "constr_homology=",constr_homology
4485 c      write(iout,*) i, j, k, "TEST K"
4486          enddo
4487          if (waga_dist.ge.0.0d0) then
4488 c
4489 c          For Gaussian-type Urestr
4490 c
4491             grad_odl3=waga_homology(iset)*waga_dist
4492      &                *sum_sgodl/(sum_godl*dij)
4493 c
4494 c          For Lorentzian-type Urestr
4495 c
4496          else
4497 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4498 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4499             grad_odl3=-waga_homology(iset)*waga_dist*
4500      &                sum_sgodl/(constr_homology*dij)
4501          endif
4502 c
4503 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4504
4505
4506 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4507 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4508 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4509
4510 ccc      write(iout,*) godl, sgodl, grad_odl3
4511
4512 c          grad_odl=grad_odl+grad_odl3
4513
4514          do jik=1,3
4515             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4516 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4517 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4518 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4519             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4520             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4521 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4522 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4523 c         if (i.eq.25.and.j.eq.27) then
4524 c         write(iout,*) "jik",jik,"i",i,"j",j
4525 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4526 c         write(iout,*) "grad_odl3",grad_odl3
4527 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4528 c         write(iout,*) "ggodl",ggodl
4529 c         write(iout,*) "ghpbc(",jik,i,")",
4530 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4531 c     &                 ghpbc(jik,j)
4532 c         endif
4533          enddo
4534 #endif
4535 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4536 ccc     & dLOG(odleg2),"-odleg=", -odleg
4537
4538       enddo ! ii-loop for dist
4539 #ifdef DEBUG
4540       write(iout,*) "------- dist restrs end -------"
4541 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4542 c    &     waga_d.eq.1.0d0) call sum_gradient
4543 #endif
4544 c Pseudo-energy and gradient from dihedral-angle restraints from
4545 c homology templates
4546 c      write (iout,*) "End of distance loop"
4547 c      call flush(iout)
4548       kat=0.0d0
4549 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4550 #ifdef DEBUG
4551       write(iout,*) "------- dih restrs start -------"
4552       do i=idihconstr_start_homo,idihconstr_end_homo
4553         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4554       enddo
4555 #endif
4556       do i=idihconstr_start_homo,idihconstr_end_homo
4557         kat2=0.0d0
4558 c        betai=beta(i,i+1,i+2,i+3)
4559         betai = phi(i)
4560 c       write (iout,*) "betai =",betai
4561         do k=1,constr_homology
4562           dih_diff(k)=pinorm(dih(k,i)-betai)
4563 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4564 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4565 c     &                                   -(6.28318-dih_diff(i,k))
4566 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4567 c     &                                   6.28318+dih_diff(i,k)
4568 #ifdef OLD_DIHED
4569           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4570 #else
4571           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4572 #endif
4573 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4574           gdih(k)=dexp(kat3)
4575           kat2=kat2+gdih(k)
4576 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4577 c          write(*,*)""
4578         enddo
4579 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4580 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4581 #ifdef DEBUG
4582         write (iout,*) "i",i," betai",betai," kat2",kat2
4583         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4584 #endif
4585         if (kat2.le.1.0d-14) cycle
4586         kat=kat-dLOG(kat2/constr_homology)
4587 c       write (iout,*) "kat",kat ! sum of -ln-s
4588
4589 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4590 ccc     & dLOG(kat2), "-kat=", -kat
4591
4592 #ifdef GRAD
4593 c ----------------------------------------------------------------------
4594 c Gradient
4595 c ----------------------------------------------------------------------
4596
4597         sum_gdih=kat2
4598         sum_sgdih=0.0d0
4599         do k=1,constr_homology
4600 #ifdef OLD_DIHED
4601           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4602 #else
4603           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4604 #endif
4605 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4606           sum_sgdih=sum_sgdih+sgdih
4607         enddo
4608 c       grad_dih3=sum_sgdih/sum_gdih
4609         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4610
4611 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4612 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4613 ccc     & gloc(nphi+i-3,icg)
4614         gloc(i,icg)=gloc(i,icg)+grad_dih3
4615 c        if (i.eq.25) then
4616 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4617 c        endif
4618 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4619 ccc     & gloc(nphi+i-3,icg)
4620 #endif
4621       enddo ! i-loop for dih
4622 #ifdef DEBUG
4623       write(iout,*) "------- dih restrs end -------"
4624 #endif
4625
4626 c Pseudo-energy and gradient for theta angle restraints from
4627 c homology templates
4628 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4629 c adapted
4630
4631 c
4632 c     For constr_homology reference structures (FP)
4633 c
4634 c     Uconst_back_tot=0.0d0
4635       Eval=0.0d0
4636       Erot=0.0d0
4637 c     Econstr_back legacy
4638 #ifdef GRAD
4639       do i=1,nres
4640 c     do i=ithet_start,ithet_end
4641        dutheta(i)=0.0d0
4642 c     enddo
4643 c     do i=loc_start,loc_end
4644         do j=1,3
4645           duscdiff(j,i)=0.0d0
4646           duscdiffx(j,i)=0.0d0
4647         enddo
4648       enddo
4649 #endif
4650 c
4651 c     do iref=1,nref
4652 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4653 c     write (iout,*) "waga_theta",waga_theta
4654       if (waga_theta.gt.0.0d0) then
4655 #ifdef DEBUG
4656       write (iout,*) "usampl",usampl
4657       write(iout,*) "------- theta restrs start -------"
4658 c     do i=ithet_start,ithet_end
4659 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4660 c     enddo
4661 #endif
4662 c     write (iout,*) "maxres",maxres,"nres",nres
4663
4664       do i=ithet_start,ithet_end
4665 c
4666 c     do i=1,nfrag_back
4667 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4668 c
4669 c Deviation of theta angles wrt constr_homology ref structures
4670 c
4671         utheta_i=0.0d0 ! argument of Gaussian for single k
4672         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4673 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4674 c       over residues in a fragment
4675 c       write (iout,*) "theta(",i,")=",theta(i)
4676         do k=1,constr_homology
4677 c
4678 c         dtheta_i=theta(j)-thetaref(j,iref)
4679 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4680           theta_diff(k)=thetatpl(k,i)-theta(i)
4681 c
4682           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4683 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4684           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4685           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4686 c         Gradient for single Gaussian restraint in subr Econstr_back
4687 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4688 c
4689         enddo
4690 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4691 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4692
4693 c
4694 #ifdef GRAD
4695 c         Gradient for multiple Gaussian restraint
4696         sum_gtheta=gutheta_i
4697         sum_sgtheta=0.0d0
4698         do k=1,constr_homology
4699 c        New generalized expr for multiple Gaussian from Econstr_back
4700          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4701 c
4702 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4703           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4704         enddo
4705 c
4706 c       Final value of gradient using same var as in Econstr_back
4707         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4708      &               *waga_homology(iset)
4709 c       dutheta(i)=sum_sgtheta/sum_gtheta
4710 c
4711 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4712 #endif
4713         Eval=Eval-dLOG(gutheta_i/constr_homology)
4714 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4715 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4716 c       Uconst_back=Uconst_back+utheta(i)
4717       enddo ! (i-loop for theta)
4718 #ifdef DEBUG
4719       write(iout,*) "------- theta restrs end -------"
4720 #endif
4721       endif
4722 c
4723 c Deviation of local SC geometry
4724 c
4725 c Separation of two i-loops (instructed by AL - 11/3/2014)
4726 c
4727 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4728 c     write (iout,*) "waga_d",waga_d
4729
4730 #ifdef DEBUG
4731       write(iout,*) "------- SC restrs start -------"
4732       write (iout,*) "Initial duscdiff,duscdiffx"
4733       do i=loc_start,loc_end
4734         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4735      &                 (duscdiffx(jik,i),jik=1,3)
4736       enddo
4737 #endif
4738       do i=loc_start,loc_end
4739         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4740         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4741 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4742 c       write(iout,*) "xxtab, yytab, zztab"
4743 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4744         do k=1,constr_homology
4745 c
4746           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4747 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4748           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4749           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4750 c         write(iout,*) "dxx, dyy, dzz"
4751 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4752 c
4753           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4754 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4755 c         uscdiffk(k)=usc_diff(i)
4756           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4757           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4758 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4759 c     &      xxref(j),yyref(j),zzref(j)
4760         enddo
4761 c
4762 c       Gradient
4763 c
4764 c       Generalized expression for multiple Gaussian acc to that for a single
4765 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4766 c
4767 c       Original implementation
4768 c       sum_guscdiff=guscdiff(i)
4769 c
4770 c       sum_sguscdiff=0.0d0
4771 c       do k=1,constr_homology
4772 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4773 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4774 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4775 c       enddo
4776 c
4777 c       Implementation of new expressions for gradient (Jan. 2015)
4778 c
4779 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4780 #ifdef GRAD
4781         do k=1,constr_homology
4782 c
4783 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4784 c       before. Now the drivatives should be correct
4785 c
4786           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4787 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4788           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4789           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4790 c
4791 c         New implementation
4792 c
4793           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4794      &                 sigma_d(k,i) ! for the grad wrt r'
4795 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4796 c
4797 c
4798 c        New implementation
4799          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4800          do jik=1,3
4801             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4802      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4803      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4804             duscdiff(jik,i)=duscdiff(jik,i)+
4805      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4806      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4807             duscdiffx(jik,i)=duscdiffx(jik,i)+
4808      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4809      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4810 c
4811 #ifdef DEBUG
4812              write(iout,*) "jik",jik,"i",i
4813              write(iout,*) "dxx, dyy, dzz"
4814              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4815              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4816 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4817 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4818 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4819 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4820 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4821 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4822 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4823 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4824 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4825 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4826 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4827 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4828 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4829 c            endif
4830 #endif
4831          enddo
4832         enddo
4833 #endif
4834 c
4835 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4836 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4837 c
4838 c        write (iout,*) i," uscdiff",uscdiff(i)
4839 c
4840 c Put together deviations from local geometry
4841
4842 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4843 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4844         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4845 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4846 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4847 c       Uconst_back=Uconst_back+usc_diff(i)
4848 c
4849 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4850 c
4851 c     New implment: multiplied by sum_sguscdiff
4852 c
4853
4854       enddo ! (i-loop for dscdiff)
4855
4856 c      endif
4857
4858 #ifdef DEBUG
4859       write(iout,*) "------- SC restrs end -------"
4860         write (iout,*) "------ After SC loop in e_modeller ------"
4861         do i=loc_start,loc_end
4862          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4863          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4864         enddo
4865       if (waga_theta.eq.1.0d0) then
4866       write (iout,*) "in e_modeller after SC restr end: dutheta"
4867       do i=ithet_start,ithet_end
4868         write (iout,*) i,dutheta(i)
4869       enddo
4870       endif
4871       if (waga_d.eq.1.0d0) then
4872       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4873       do i=1,nres
4874         write (iout,*) i,(duscdiff(j,i),j=1,3)
4875         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4876       enddo
4877       endif
4878 #endif
4879
4880 c Total energy from homology restraints
4881 #ifdef DEBUG
4882       write (iout,*) "odleg",odleg," kat",kat
4883       write (iout,*) "odleg",odleg," kat",kat
4884       write (iout,*) "Eval",Eval," Erot",Erot
4885       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4886       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4887       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4888 #endif
4889 c
4890 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4891 c
4892 c     ehomology_constr=odleg+kat
4893 c
4894 c     For Lorentzian-type Urestr
4895 c
4896
4897       if (waga_dist.ge.0.0d0) then
4898 c
4899 c          For Gaussian-type Urestr
4900 c
4901 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4902 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4903         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4904      &              waga_theta*Eval+waga_d*Erot
4905 c     write (iout,*) "ehomology_constr=",ehomology_constr
4906       else
4907 c
4908 c          For Lorentzian-type Urestr
4909 c
4910 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4911 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4912         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4913      &              waga_theta*Eval+waga_d*Erot
4914 c     write (iout,*) "ehomology_constr=",ehomology_constr
4915       endif
4916 #ifdef DEBUG
4917       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4918      & "Eval",waga_theta,eval,
4919      &   "Erot",waga_d,Erot
4920       write (iout,*) "ehomology_constr",ehomology_constr
4921 #endif
4922       return
4923
4924   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4925   747 format(a12,i4,i4,i4,f8.3,f8.3)
4926   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4927   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4928   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4929      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4930       end
4931 c-----------------------------------------------------------------------
4932       subroutine ebond(estr)
4933 c
4934 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4935 c
4936       implicit real*8 (a-h,o-z)
4937       include 'DIMENSIONS'
4938       include 'DIMENSIONS.ZSCOPT'
4939       include 'COMMON.LOCAL'
4940       include 'COMMON.GEO'
4941       include 'COMMON.INTERACT'
4942       include 'COMMON.DERIV'
4943       include 'COMMON.VAR'
4944       include 'COMMON.CHAIN'
4945       include 'COMMON.IOUNITS'
4946       include 'COMMON.NAMES'
4947       include 'COMMON.FFIELD'
4948       include 'COMMON.CONTROL'
4949       double precision u(3),ud(3)
4950       estr=0.0d0
4951       estr1=0.0d0
4952 c      write (iout,*) "distchainmax",distchainmax
4953       do i=nnt+1,nct
4954 #ifdef FIVEDIAG
4955         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4956         diff = vbld(i)-vbldp0
4957 #else
4958         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4959 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4960 C          do j=1,3
4961 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4962 C     &      *dc(j,i-1)/vbld(i)
4963 C          enddo
4964 C          if (energy_dec) write(iout,*)
4965 C     &       "estr1",i,vbld(i),distchainmax,
4966 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4967 C        else
4968          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4969         diff = vbld(i)-vbldpDUM
4970 C         write(iout,*) i,diff
4971          else
4972           diff = vbld(i)-vbldp0
4973 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4974          endif
4975 #endif
4976           estr=estr+diff*diff
4977           do j=1,3
4978             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4979           enddo
4980 C        endif
4981           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4982      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4983       enddo
4984       estr=0.5d0*AKP*estr+estr1
4985 c
4986 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4987 c
4988       do i=nnt,nct
4989         iti=iabs(itype(i))
4990         if (iti.ne.10 .and. iti.ne.ntyp1) then
4991           nbi=nbondterm(iti)
4992           if (nbi.eq.1) then
4993             diff=vbld(i+nres)-vbldsc0(1,iti)
4994             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
4995      &      vbldsc0(1,iti),diff,
4996      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4997             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4998             do j=1,3
4999               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5000             enddo
5001           else
5002             do j=1,nbi
5003               diff=vbld(i+nres)-vbldsc0(j,iti)
5004               ud(j)=aksc(j,iti)*diff
5005               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5006             enddo
5007             uprod=u(1)
5008             do j=2,nbi
5009               uprod=uprod*u(j)
5010             enddo
5011             usum=0.0d0
5012             usumsqder=0.0d0
5013             do j=1,nbi
5014               uprod1=1.0d0
5015               uprod2=1.0d0
5016               do k=1,nbi
5017                 if (k.ne.j) then
5018                   uprod1=uprod1*u(k)
5019                   uprod2=uprod2*u(k)*u(k)
5020                 endif
5021               enddo
5022               usum=usum+uprod1
5023               usumsqder=usumsqder+ud(j)*uprod2
5024             enddo
5025 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5026 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5027             estr=estr+uprod/usum
5028             do j=1,3
5029              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5030             enddo
5031           endif
5032         endif
5033       enddo
5034       return
5035       end
5036 #ifdef CRYST_THETA
5037 C--------------------------------------------------------------------------
5038       subroutine ebend(etheta,ethetacnstr)
5039 C
5040 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5041 C angles gamma and its derivatives in consecutive thetas and gammas.
5042 C
5043       implicit real*8 (a-h,o-z)
5044       include 'DIMENSIONS'
5045       include 'DIMENSIONS.ZSCOPT'
5046       include 'COMMON.LOCAL'
5047       include 'COMMON.GEO'
5048       include 'COMMON.INTERACT'
5049       include 'COMMON.DERIV'
5050       include 'COMMON.VAR'
5051       include 'COMMON.CHAIN'
5052       include 'COMMON.IOUNITS'
5053       include 'COMMON.NAMES'
5054       include 'COMMON.FFIELD'
5055       include 'COMMON.TORCNSTR'
5056       common /calcthet/ term1,term2,termm,diffak,ratak,
5057      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5058      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5059       double precision y(2),z(2)
5060       delta=0.02d0*pi
5061 c      time11=dexp(-2*time)
5062 c      time12=1.0d0
5063       etheta=0.0D0
5064 c      write (iout,*) "nres",nres
5065 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5066 c      write (iout,*) ithet_start,ithet_end
5067       do i=ithet_start,ithet_end
5068 C        if (itype(i-1).eq.ntyp1) cycle
5069         if (i.le.2) cycle
5070         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5071      &  .or.itype(i).eq.ntyp1) cycle
5072 C Zero the energy function and its derivative at 0 or pi.
5073         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5074         it=itype(i-1)
5075         ichir1=isign(1,itype(i-2))
5076         ichir2=isign(1,itype(i))
5077          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5078          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5079          if (itype(i-1).eq.10) then
5080           itype1=isign(10,itype(i-2))
5081           ichir11=isign(1,itype(i-2))
5082           ichir12=isign(1,itype(i-2))
5083           itype2=isign(10,itype(i))
5084           ichir21=isign(1,itype(i))
5085           ichir22=isign(1,itype(i))
5086          endif
5087          if (i.eq.3) then
5088           y(1)=0.0D0
5089           y(2)=0.0D0
5090           else
5091
5092         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5093 #ifdef OSF
5094           phii=phi(i)
5095 c          icrc=0
5096 c          call proc_proc(phii,icrc)
5097           if (icrc.eq.1) phii=150.0
5098 #else
5099           phii=phi(i)
5100 #endif
5101           y(1)=dcos(phii)
5102           y(2)=dsin(phii)
5103         else
5104           y(1)=0.0D0
5105           y(2)=0.0D0
5106         endif
5107         endif
5108         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5109 #ifdef OSF
5110           phii1=phi(i+1)
5111 c          icrc=0
5112 c          call proc_proc(phii1,icrc)
5113           if (icrc.eq.1) phii1=150.0
5114           phii1=pinorm(phii1)
5115           z(1)=cos(phii1)
5116 #else
5117           phii1=phi(i+1)
5118           z(1)=dcos(phii1)
5119 #endif
5120           z(2)=dsin(phii1)
5121         else
5122           z(1)=0.0D0
5123           z(2)=0.0D0
5124         endif
5125 C Calculate the "mean" value of theta from the part of the distribution
5126 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5127 C In following comments this theta will be referred to as t_c.
5128         thet_pred_mean=0.0d0
5129         do k=1,2
5130             athetk=athet(k,it,ichir1,ichir2)
5131             bthetk=bthet(k,it,ichir1,ichir2)
5132           if (it.eq.10) then
5133              athetk=athet(k,itype1,ichir11,ichir12)
5134              bthetk=bthet(k,itype2,ichir21,ichir22)
5135           endif
5136           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5137         enddo
5138 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5139         dthett=thet_pred_mean*ssd
5140         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5141 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5142 C Derivatives of the "mean" values in gamma1 and gamma2.
5143         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5144      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5145          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5146      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5147          if (it.eq.10) then
5148       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5149      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5150         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5151      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5152          endif
5153         if (theta(i).gt.pi-delta) then
5154           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5155      &         E_tc0)
5156           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5157           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5158           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5159      &        E_theta)
5160           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5161      &        E_tc)
5162         else if (theta(i).lt.delta) then
5163           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5164           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5165           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5166      &        E_theta)
5167           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5168           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5169      &        E_tc)
5170         else
5171           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5172      &        E_theta,E_tc)
5173         endif
5174         etheta=etheta+ethetai
5175 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5176 c     &      'ebend',i,ethetai,theta(i),itype(i)
5177 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5178 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5179         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5180         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5181         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5182 c 1215   continue
5183       enddo
5184       ethetacnstr=0.0d0
5185 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5186       do i=1,ntheta_constr
5187         itheta=itheta_constr(i)
5188         thetiii=theta(itheta)
5189         difi=pinorm(thetiii-theta_constr0(i))
5190         if (difi.gt.theta_drange(i)) then
5191           difi=difi-theta_drange(i)
5192           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5193           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5194      &    +for_thet_constr(i)*difi**3
5195         else if (difi.lt.-drange(i)) then
5196           difi=difi+drange(i)
5197           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5198           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5199      &    +for_thet_constr(i)*difi**3
5200         else
5201           difi=0.0
5202         endif
5203 C       if (energy_dec) then
5204 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5205 C     &    i,itheta,rad2deg*thetiii,
5206 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5207 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5208 C     &    gloc(itheta+nphi-2,icg)
5209 C        endif
5210       enddo
5211 C Ufff.... We've done all this!!!
5212       return
5213       end
5214 C---------------------------------------------------------------------------
5215       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5216      &     E_tc)
5217       implicit real*8 (a-h,o-z)
5218       include 'DIMENSIONS'
5219       include 'COMMON.LOCAL'
5220       include 'COMMON.IOUNITS'
5221       common /calcthet/ term1,term2,termm,diffak,ratak,
5222      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5223      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5224 C Calculate the contributions to both Gaussian lobes.
5225 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5226 C The "polynomial part" of the "standard deviation" of this part of
5227 C the distribution.
5228         sig=polthet(3,it)
5229         do j=2,0,-1
5230           sig=sig*thet_pred_mean+polthet(j,it)
5231         enddo
5232 C Derivative of the "interior part" of the "standard deviation of the"
5233 C gamma-dependent Gaussian lobe in t_c.
5234         sigtc=3*polthet(3,it)
5235         do j=2,1,-1
5236           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5237         enddo
5238         sigtc=sig*sigtc
5239 C Set the parameters of both Gaussian lobes of the distribution.
5240 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5241         fac=sig*sig+sigc0(it)
5242         sigcsq=fac+fac
5243         sigc=1.0D0/sigcsq
5244 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5245         sigsqtc=-4.0D0*sigcsq*sigtc
5246 c       print *,i,sig,sigtc,sigsqtc
5247 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5248         sigtc=-sigtc/(fac*fac)
5249 C Following variable is sigma(t_c)**(-2)
5250         sigcsq=sigcsq*sigcsq
5251         sig0i=sig0(it)
5252         sig0inv=1.0D0/sig0i**2
5253         delthec=thetai-thet_pred_mean
5254         delthe0=thetai-theta0i
5255         term1=-0.5D0*sigcsq*delthec*delthec
5256         term2=-0.5D0*sig0inv*delthe0*delthe0
5257 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5258 C NaNs in taking the logarithm. We extract the largest exponent which is added
5259 C to the energy (this being the log of the distribution) at the end of energy
5260 C term evaluation for this virtual-bond angle.
5261         if (term1.gt.term2) then
5262           termm=term1
5263           term2=dexp(term2-termm)
5264           term1=1.0d0
5265         else
5266           termm=term2
5267           term1=dexp(term1-termm)
5268           term2=1.0d0
5269         endif
5270 C The ratio between the gamma-independent and gamma-dependent lobes of
5271 C the distribution is a Gaussian function of thet_pred_mean too.
5272         diffak=gthet(2,it)-thet_pred_mean
5273         ratak=diffak/gthet(3,it)**2
5274         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5275 C Let's differentiate it in thet_pred_mean NOW.
5276         aktc=ak*ratak
5277 C Now put together the distribution terms to make complete distribution.
5278         termexp=term1+ak*term2
5279         termpre=sigc+ak*sig0i
5280 C Contribution of the bending energy from this theta is just the -log of
5281 C the sum of the contributions from the two lobes and the pre-exponential
5282 C factor. Simple enough, isn't it?
5283         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5284 C NOW the derivatives!!!
5285 C 6/6/97 Take into account the deformation.
5286         E_theta=(delthec*sigcsq*term1
5287      &       +ak*delthe0*sig0inv*term2)/termexp
5288         E_tc=((sigtc+aktc*sig0i)/termpre
5289      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5290      &       aktc*term2)/termexp)
5291       return
5292       end
5293 c-----------------------------------------------------------------------------
5294       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5295       implicit real*8 (a-h,o-z)
5296       include 'DIMENSIONS'
5297       include 'COMMON.LOCAL'
5298       include 'COMMON.IOUNITS'
5299       common /calcthet/ term1,term2,termm,diffak,ratak,
5300      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5301      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5302       delthec=thetai-thet_pred_mean
5303       delthe0=thetai-theta0i
5304 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5305       t3 = thetai-thet_pred_mean
5306       t6 = t3**2
5307       t9 = term1
5308       t12 = t3*sigcsq
5309       t14 = t12+t6*sigsqtc
5310       t16 = 1.0d0
5311       t21 = thetai-theta0i
5312       t23 = t21**2
5313       t26 = term2
5314       t27 = t21*t26
5315       t32 = termexp
5316       t40 = t32**2
5317       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5318      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5319      & *(-t12*t9-ak*sig0inv*t27)
5320       return
5321       end
5322 #else
5323 C--------------------------------------------------------------------------
5324       subroutine ebend(etheta)
5325 C
5326 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5327 C angles gamma and its derivatives in consecutive thetas and gammas.
5328 C ab initio-derived potentials from
5329 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5330 C
5331       implicit real*8 (a-h,o-z)
5332       include 'DIMENSIONS'
5333       include 'DIMENSIONS.ZSCOPT'
5334       include 'COMMON.LOCAL'
5335       include 'COMMON.GEO'
5336       include 'COMMON.INTERACT'
5337       include 'COMMON.DERIV'
5338       include 'COMMON.VAR'
5339       include 'COMMON.CHAIN'
5340       include 'COMMON.IOUNITS'
5341       include 'COMMON.NAMES'
5342       include 'COMMON.FFIELD'
5343       include 'COMMON.CONTROL'
5344       include 'COMMON.TORCNSTR'
5345       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5346      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5347      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5348      & sinph1ph2(maxdouble,maxdouble)
5349       logical lprn /.false./, lprn1 /.false./
5350       etheta=0.0D0
5351 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5352       do i=ithet_start,ithet_end
5353 C         if (i.eq.2) cycle
5354 C        if (itype(i-1).eq.ntyp1) cycle
5355         if (i.le.2) cycle
5356         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5357      &  .or.itype(i).eq.ntyp1) cycle
5358         if (iabs(itype(i+1)).eq.20) iblock=2
5359         if (iabs(itype(i+1)).ne.20) iblock=1
5360         dethetai=0.0d0
5361         dephii=0.0d0
5362         dephii1=0.0d0
5363         theti2=0.5d0*theta(i)
5364         ityp2=ithetyp((itype(i-1)))
5365         do k=1,nntheterm
5366           coskt(k)=dcos(k*theti2)
5367           sinkt(k)=dsin(k*theti2)
5368         enddo
5369 cu        if (i.eq.3) then
5370 cu          phii=0.0d0
5371 cu          ityp1=nthetyp+1
5372 cu          do k=1,nsingle
5373 cu            cosph1(k)=0.0d0
5374 cu            sinph1(k)=0.0d0
5375 cu          enddo
5376 cu        else
5377         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5378 #ifdef OSF
5379           phii=phi(i)
5380           if (phii.ne.phii) phii=150.0
5381 #else
5382           phii=phi(i)
5383 #endif
5384           ityp1=ithetyp((itype(i-2)))
5385           do k=1,nsingle
5386             cosph1(k)=dcos(k*phii)
5387             sinph1(k)=dsin(k*phii)
5388           enddo
5389         else
5390           phii=0.0d0
5391 c          ityp1=nthetyp+1
5392           do k=1,nsingle
5393             ityp1=ithetyp((itype(i-2)))
5394             cosph1(k)=0.0d0
5395             sinph1(k)=0.0d0
5396           enddo
5397         endif
5398         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5399 #ifdef OSF
5400           phii1=phi(i+1)
5401           if (phii1.ne.phii1) phii1=150.0
5402           phii1=pinorm(phii1)
5403 #else
5404           phii1=phi(i+1)
5405 #endif
5406           ityp3=ithetyp((itype(i)))
5407           do k=1,nsingle
5408             cosph2(k)=dcos(k*phii1)
5409             sinph2(k)=dsin(k*phii1)
5410           enddo
5411         else
5412           phii1=0.0d0
5413 c          ityp3=nthetyp+1
5414           ityp3=ithetyp((itype(i)))
5415           do k=1,nsingle
5416             cosph2(k)=0.0d0
5417             sinph2(k)=0.0d0
5418           enddo
5419         endif
5420 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5421 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5422 c        call flush(iout)
5423         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5424         do k=1,ndouble
5425           do l=1,k-1
5426             ccl=cosph1(l)*cosph2(k-l)
5427             ssl=sinph1(l)*sinph2(k-l)
5428             scl=sinph1(l)*cosph2(k-l)
5429             csl=cosph1(l)*sinph2(k-l)
5430             cosph1ph2(l,k)=ccl-ssl
5431             cosph1ph2(k,l)=ccl+ssl
5432             sinph1ph2(l,k)=scl+csl
5433             sinph1ph2(k,l)=scl-csl
5434           enddo
5435         enddo
5436         if (lprn) then
5437         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5438      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5439         write (iout,*) "coskt and sinkt"
5440         do k=1,nntheterm
5441           write (iout,*) k,coskt(k),sinkt(k)
5442         enddo
5443         endif
5444         do k=1,ntheterm
5445           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5446           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5447      &      *coskt(k)
5448           if (lprn)
5449      &    write (iout,*) "k",k,"
5450      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5451      &     " ethetai",ethetai
5452         enddo
5453         if (lprn) then
5454         write (iout,*) "cosph and sinph"
5455         do k=1,nsingle
5456           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5457         enddo
5458         write (iout,*) "cosph1ph2 and sinph2ph2"
5459         do k=2,ndouble
5460           do l=1,k-1
5461             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5462      &         sinph1ph2(l,k),sinph1ph2(k,l)
5463           enddo
5464         enddo
5465         write(iout,*) "ethetai",ethetai
5466         endif
5467         do m=1,ntheterm2
5468           do k=1,nsingle
5469             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5470      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5471      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5472      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5473             ethetai=ethetai+sinkt(m)*aux
5474             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5475             dephii=dephii+k*sinkt(m)*(
5476      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5477      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5478             dephii1=dephii1+k*sinkt(m)*(
5479      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5480      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5481             if (lprn)
5482      &      write (iout,*) "m",m," k",k," bbthet",
5483      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5484      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5485      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5486      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5487           enddo
5488         enddo
5489         if (lprn)
5490      &  write(iout,*) "ethetai",ethetai
5491         do m=1,ntheterm3
5492           do k=2,ndouble
5493             do l=1,k-1
5494               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5495      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5496      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5497      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5498               ethetai=ethetai+sinkt(m)*aux
5499               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5500               dephii=dephii+l*sinkt(m)*(
5501      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5502      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5503      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5504      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5505               dephii1=dephii1+(k-l)*sinkt(m)*(
5506      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5507      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5508      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5509      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5510               if (lprn) then
5511               write (iout,*) "m",m," k",k," l",l," ffthet",
5512      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5513      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5514      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5515      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5516      &            " ethetai",ethetai
5517               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5518      &            cosph1ph2(k,l)*sinkt(m),
5519      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5520               endif
5521             enddo
5522           enddo
5523         enddo
5524 10      continue
5525         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5526      &   i,theta(i)*rad2deg,phii*rad2deg,
5527      &   phii1*rad2deg,ethetai
5528         etheta=etheta+ethetai
5529         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5530         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5531 c        gloc(nphi+i-2,icg)=wang*dethetai
5532         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5533       enddo
5534       return
5535       end
5536 #endif
5537 #ifdef CRYST_SC
5538 c-----------------------------------------------------------------------------
5539       subroutine esc(escloc)
5540 C Calculate the local energy of a side chain and its derivatives in the
5541 C corresponding virtual-bond valence angles THETA and the spherical angles
5542 C ALPHA and OMEGA.
5543       implicit real*8 (a-h,o-z)
5544       include 'DIMENSIONS'
5545       include 'DIMENSIONS.ZSCOPT'
5546       include 'COMMON.GEO'
5547       include 'COMMON.LOCAL'
5548       include 'COMMON.VAR'
5549       include 'COMMON.INTERACT'
5550       include 'COMMON.DERIV'
5551       include 'COMMON.CHAIN'
5552       include 'COMMON.IOUNITS'
5553       include 'COMMON.NAMES'
5554       include 'COMMON.FFIELD'
5555       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5556      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5557       common /sccalc/ time11,time12,time112,theti,it,nlobit
5558       delta=0.02d0*pi
5559       escloc=0.0D0
5560 C      write (iout,*) 'ESC'
5561       do i=loc_start,loc_end
5562         it=itype(i)
5563         if (it.eq.ntyp1) cycle
5564         if (it.eq.10) goto 1
5565         nlobit=nlob(iabs(it))
5566 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5567 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5568         theti=theta(i+1)-pipol
5569         x(1)=dtan(theti)
5570         x(2)=alph(i)
5571         x(3)=omeg(i)
5572 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5573
5574         if (x(2).gt.pi-delta) then
5575           xtemp(1)=x(1)
5576           xtemp(2)=pi-delta
5577           xtemp(3)=x(3)
5578           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5579           xtemp(2)=pi
5580           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5581           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5582      &        escloci,dersc(2))
5583           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5584      &        ddersc0(1),dersc(1))
5585           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5586      &        ddersc0(3),dersc(3))
5587           xtemp(2)=pi-delta
5588           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5589           xtemp(2)=pi
5590           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5591           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5592      &            dersc0(2),esclocbi,dersc02)
5593           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5594      &            dersc12,dersc01)
5595           call splinthet(x(2),0.5d0*delta,ss,ssd)
5596           dersc0(1)=dersc01
5597           dersc0(2)=dersc02
5598           dersc0(3)=0.0d0
5599           do k=1,3
5600             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5601           enddo
5602           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5603           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5604      &             esclocbi,ss,ssd
5605           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5606 c         escloci=esclocbi
5607 c         write (iout,*) escloci
5608         else if (x(2).lt.delta) then
5609           xtemp(1)=x(1)
5610           xtemp(2)=delta
5611           xtemp(3)=x(3)
5612           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5613           xtemp(2)=0.0d0
5614           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5615           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5616      &        escloci,dersc(2))
5617           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5618      &        ddersc0(1),dersc(1))
5619           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5620      &        ddersc0(3),dersc(3))
5621           xtemp(2)=delta
5622           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5623           xtemp(2)=0.0d0
5624           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5625           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5626      &            dersc0(2),esclocbi,dersc02)
5627           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5628      &            dersc12,dersc01)
5629           dersc0(1)=dersc01
5630           dersc0(2)=dersc02
5631           dersc0(3)=0.0d0
5632           call splinthet(x(2),0.5d0*delta,ss,ssd)
5633           do k=1,3
5634             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5635           enddo
5636           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5637 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5638 c     &             esclocbi,ss,ssd
5639           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5640 C         write (iout,*) 'i=',i, escloci
5641         else
5642           call enesc(x,escloci,dersc,ddummy,.false.)
5643         endif
5644
5645         escloc=escloc+escloci
5646 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5647             write (iout,'(a6,i5,0pf7.3)')
5648      &     'escloc',i,escloci
5649
5650         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5651      &   wscloc*dersc(1)
5652         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5653         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5654     1   continue
5655       enddo
5656       return
5657       end
5658 C---------------------------------------------------------------------------
5659       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5660       implicit real*8 (a-h,o-z)
5661       include 'DIMENSIONS'
5662       include 'COMMON.GEO'
5663       include 'COMMON.LOCAL'
5664       include 'COMMON.IOUNITS'
5665       common /sccalc/ time11,time12,time112,theti,it,nlobit
5666       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5667       double precision contr(maxlob,-1:1)
5668       logical mixed
5669 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5670         escloc_i=0.0D0
5671         do j=1,3
5672           dersc(j)=0.0D0
5673           if (mixed) ddersc(j)=0.0d0
5674         enddo
5675         x3=x(3)
5676
5677 C Because of periodicity of the dependence of the SC energy in omega we have
5678 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5679 C To avoid underflows, first compute & store the exponents.
5680
5681         do iii=-1,1
5682
5683           x(3)=x3+iii*dwapi
5684
5685           do j=1,nlobit
5686             do k=1,3
5687               z(k)=x(k)-censc(k,j,it)
5688             enddo
5689             do k=1,3
5690               Axk=0.0D0
5691               do l=1,3
5692                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5693               enddo
5694               Ax(k,j,iii)=Axk
5695             enddo
5696             expfac=0.0D0
5697             do k=1,3
5698               expfac=expfac+Ax(k,j,iii)*z(k)
5699             enddo
5700             contr(j,iii)=expfac
5701           enddo ! j
5702
5703         enddo ! iii
5704
5705         x(3)=x3
5706 C As in the case of ebend, we want to avoid underflows in exponentiation and
5707 C subsequent NaNs and INFs in energy calculation.
5708 C Find the largest exponent
5709         emin=contr(1,-1)
5710         do iii=-1,1
5711           do j=1,nlobit
5712             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5713           enddo
5714         enddo
5715         emin=0.5D0*emin
5716 cd      print *,'it=',it,' emin=',emin
5717
5718 C Compute the contribution to SC energy and derivatives
5719         do iii=-1,1
5720
5721           do j=1,nlobit
5722             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5723 cd          print *,'j=',j,' expfac=',expfac
5724             escloc_i=escloc_i+expfac
5725             do k=1,3
5726               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5727             enddo
5728             if (mixed) then
5729               do k=1,3,2
5730                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5731      &            +gaussc(k,2,j,it))*expfac
5732               enddo
5733             endif
5734           enddo
5735
5736         enddo ! iii
5737
5738         dersc(1)=dersc(1)/cos(theti)**2
5739         ddersc(1)=ddersc(1)/cos(theti)**2
5740         ddersc(3)=ddersc(3)
5741
5742         escloci=-(dlog(escloc_i)-emin)
5743         do j=1,3
5744           dersc(j)=dersc(j)/escloc_i
5745         enddo
5746         if (mixed) then
5747           do j=1,3,2
5748             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5749           enddo
5750         endif
5751       return
5752       end
5753 C------------------------------------------------------------------------------
5754       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5755       implicit real*8 (a-h,o-z)
5756       include 'DIMENSIONS'
5757       include 'COMMON.GEO'
5758       include 'COMMON.LOCAL'
5759       include 'COMMON.IOUNITS'
5760       common /sccalc/ time11,time12,time112,theti,it,nlobit
5761       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5762       double precision contr(maxlob)
5763       logical mixed
5764
5765       escloc_i=0.0D0
5766
5767       do j=1,3
5768         dersc(j)=0.0D0
5769       enddo
5770
5771       do j=1,nlobit
5772         do k=1,2
5773           z(k)=x(k)-censc(k,j,it)
5774         enddo
5775         z(3)=dwapi
5776         do k=1,3
5777           Axk=0.0D0
5778           do l=1,3
5779             Axk=Axk+gaussc(l,k,j,it)*z(l)
5780           enddo
5781           Ax(k,j)=Axk
5782         enddo
5783         expfac=0.0D0
5784         do k=1,3
5785           expfac=expfac+Ax(k,j)*z(k)
5786         enddo
5787         contr(j)=expfac
5788       enddo ! j
5789
5790 C As in the case of ebend, we want to avoid underflows in exponentiation and
5791 C subsequent NaNs and INFs in energy calculation.
5792 C Find the largest exponent
5793       emin=contr(1)
5794       do j=1,nlobit
5795         if (emin.gt.contr(j)) emin=contr(j)
5796       enddo
5797       emin=0.5D0*emin
5798
5799 C Compute the contribution to SC energy and derivatives
5800
5801       dersc12=0.0d0
5802       do j=1,nlobit
5803         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5804         escloc_i=escloc_i+expfac
5805         do k=1,2
5806           dersc(k)=dersc(k)+Ax(k,j)*expfac
5807         enddo
5808         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5809      &            +gaussc(1,2,j,it))*expfac
5810         dersc(3)=0.0d0
5811       enddo
5812
5813       dersc(1)=dersc(1)/cos(theti)**2
5814       dersc12=dersc12/cos(theti)**2
5815       escloci=-(dlog(escloc_i)-emin)
5816       do j=1,2
5817         dersc(j)=dersc(j)/escloc_i
5818       enddo
5819       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5820       return
5821       end
5822 #else
5823 c----------------------------------------------------------------------------------
5824       subroutine esc(escloc)
5825 C Calculate the local energy of a side chain and its derivatives in the
5826 C corresponding virtual-bond valence angles THETA and the spherical angles
5827 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5828 C added by Urszula Kozlowska. 07/11/2007
5829 C
5830       implicit real*8 (a-h,o-z)
5831       include 'DIMENSIONS'
5832       include 'DIMENSIONS.ZSCOPT'
5833       include 'COMMON.GEO'
5834       include 'COMMON.LOCAL'
5835       include 'COMMON.VAR'
5836       include 'COMMON.SCROT'
5837       include 'COMMON.INTERACT'
5838       include 'COMMON.DERIV'
5839       include 'COMMON.CHAIN'
5840       include 'COMMON.IOUNITS'
5841       include 'COMMON.NAMES'
5842       include 'COMMON.FFIELD'
5843       include 'COMMON.CONTROL'
5844       include 'COMMON.VECTORS'
5845       double precision x_prime(3),y_prime(3),z_prime(3)
5846      &    , sumene,dsc_i,dp2_i,x(65),
5847      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5848      &    de_dxx,de_dyy,de_dzz,de_dt
5849       double precision s1_t,s1_6_t,s2_t,s2_6_t
5850       double precision
5851      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5852      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5853      & dt_dCi(3),dt_dCi1(3)
5854       common /sccalc/ time11,time12,time112,theti,it,nlobit
5855       delta=0.02d0*pi
5856       escloc=0.0D0
5857       do i=loc_start,loc_end
5858         if (itype(i).eq.ntyp1) cycle
5859         costtab(i+1) =dcos(theta(i+1))
5860         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5861         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5862         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5863         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5864         cosfac=dsqrt(cosfac2)
5865         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5866         sinfac=dsqrt(sinfac2)
5867         it=iabs(itype(i))
5868         if (it.eq.10) goto 1
5869 c
5870 C  Compute the axes of tghe local cartesian coordinates system; store in
5871 c   x_prime, y_prime and z_prime
5872 c
5873         do j=1,3
5874           x_prime(j) = 0.00
5875           y_prime(j) = 0.00
5876           z_prime(j) = 0.00
5877         enddo
5878 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5879 C     &   dc_norm(3,i+nres)
5880         do j = 1,3
5881           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5882           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5883         enddo
5884         do j = 1,3
5885           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5886         enddo
5887 c       write (2,*) "i",i
5888 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5889 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5890 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5891 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5892 c      & " xy",scalar(x_prime(1),y_prime(1)),
5893 c      & " xz",scalar(x_prime(1),z_prime(1)),
5894 c      & " yy",scalar(y_prime(1),y_prime(1)),
5895 c      & " yz",scalar(y_prime(1),z_prime(1)),
5896 c      & " zz",scalar(z_prime(1),z_prime(1))
5897 c
5898 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5899 C to local coordinate system. Store in xx, yy, zz.
5900 c
5901         xx=0.0d0
5902         yy=0.0d0
5903         zz=0.0d0
5904         do j = 1,3
5905           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5906           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5907           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5908         enddo
5909
5910         xxtab(i)=xx
5911         yytab(i)=yy
5912         zztab(i)=zz
5913 C
5914 C Compute the energy of the ith side cbain
5915 C
5916 c        write (2,*) "xx",xx," yy",yy," zz",zz
5917         it=iabs(itype(i))
5918         do j = 1,65
5919           x(j) = sc_parmin(j,it)
5920         enddo
5921 #ifdef CHECK_COORD
5922 Cc diagnostics - remove later
5923         xx1 = dcos(alph(2))
5924         yy1 = dsin(alph(2))*dcos(omeg(2))
5925         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5926         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5927      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5928      &    xx1,yy1,zz1
5929 C,"  --- ", xx_w,yy_w,zz_w
5930 c end diagnostics
5931 #endif
5932         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5933      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5934      &   + x(10)*yy*zz
5935         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5936      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5937      & + x(20)*yy*zz
5938         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5939      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5940      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5941      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5942      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5943      &  +x(40)*xx*yy*zz
5944         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5945      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5946      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5947      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5948      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5949      &  +x(60)*xx*yy*zz
5950         dsc_i   = 0.743d0+x(61)
5951         dp2_i   = 1.9d0+x(62)
5952         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5953      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5954         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5955      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5956         s1=(1+x(63))/(0.1d0 + dscp1)
5957         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5958         s2=(1+x(65))/(0.1d0 + dscp2)
5959         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5960         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5961      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5962 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5963 c     &   sumene4,
5964 c     &   dscp1,dscp2,sumene
5965 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5966         escloc = escloc + sumene
5967 c        write (2,*) "escloc",escloc
5968 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5969 c     &  zz,xx,yy
5970         if (.not. calc_grad) goto 1
5971 #ifdef DEBUG
5972 C
5973 C This section to check the numerical derivatives of the energy of ith side
5974 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5975 C #define DEBUG in the code to turn it on.
5976 C
5977         write (2,*) "sumene               =",sumene
5978         aincr=1.0d-7
5979         xxsave=xx
5980         xx=xx+aincr
5981         write (2,*) xx,yy,zz
5982         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5983         de_dxx_num=(sumenep-sumene)/aincr
5984         xx=xxsave
5985         write (2,*) "xx+ sumene from enesc=",sumenep
5986         yysave=yy
5987         yy=yy+aincr
5988         write (2,*) xx,yy,zz
5989         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5990         de_dyy_num=(sumenep-sumene)/aincr
5991         yy=yysave
5992         write (2,*) "yy+ sumene from enesc=",sumenep
5993         zzsave=zz
5994         zz=zz+aincr
5995         write (2,*) xx,yy,zz
5996         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5997         de_dzz_num=(sumenep-sumene)/aincr
5998         zz=zzsave
5999         write (2,*) "zz+ sumene from enesc=",sumenep
6000         costsave=cost2tab(i+1)
6001         sintsave=sint2tab(i+1)
6002         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6003         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6004         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6005         de_dt_num=(sumenep-sumene)/aincr
6006         write (2,*) " t+ sumene from enesc=",sumenep
6007         cost2tab(i+1)=costsave
6008         sint2tab(i+1)=sintsave
6009 C End of diagnostics section.
6010 #endif
6011 C
6012 C Compute the gradient of esc
6013 C
6014         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6015         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6016         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6017         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6018         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6019         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6020         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6021         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6022         pom1=(sumene3*sint2tab(i+1)+sumene1)
6023      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6024         pom2=(sumene4*cost2tab(i+1)+sumene2)
6025      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6026         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6027         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6028      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6029      &  +x(40)*yy*zz
6030         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6031         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6032      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6033      &  +x(60)*yy*zz
6034         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6035      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6036      &        +(pom1+pom2)*pom_dx
6037 #ifdef DEBUG
6038         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6039 #endif
6040 C
6041         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6042         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6043      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6044      &  +x(40)*xx*zz
6045         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6046         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6047      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6048      &  +x(59)*zz**2 +x(60)*xx*zz
6049         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6050      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6051      &        +(pom1-pom2)*pom_dy
6052 #ifdef DEBUG
6053         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6054 #endif
6055 C
6056         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6057      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6058      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6059      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6060      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6061      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6062      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6063      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6064 #ifdef DEBUG
6065         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6066 #endif
6067 C
6068         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6069      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6070      &  +pom1*pom_dt1+pom2*pom_dt2
6071 #ifdef DEBUG
6072         write(2,*), "de_dt = ", de_dt,de_dt_num
6073 #endif
6074 c
6075 C
6076        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6077        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6078        cosfac2xx=cosfac2*xx
6079        sinfac2yy=sinfac2*yy
6080        do k = 1,3
6081          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6082      &      vbld_inv(i+1)
6083          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6084      &      vbld_inv(i)
6085          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6086          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6087 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6088 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6089 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6090 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6091          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6092          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6093          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6094          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6095          dZZ_Ci1(k)=0.0d0
6096          dZZ_Ci(k)=0.0d0
6097          do j=1,3
6098            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6099      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6100            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6101      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6102          enddo
6103
6104          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6105          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6106          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6107 c
6108          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6109          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6110        enddo
6111
6112        do k=1,3
6113          dXX_Ctab(k,i)=dXX_Ci(k)
6114          dXX_C1tab(k,i)=dXX_Ci1(k)
6115          dYY_Ctab(k,i)=dYY_Ci(k)
6116          dYY_C1tab(k,i)=dYY_Ci1(k)
6117          dZZ_Ctab(k,i)=dZZ_Ci(k)
6118          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6119          dXX_XYZtab(k,i)=dXX_XYZ(k)
6120          dYY_XYZtab(k,i)=dYY_XYZ(k)
6121          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6122        enddo
6123
6124        do k = 1,3
6125 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6126 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6127 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6128 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6129 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6130 c     &    dt_dci(k)
6131 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6132 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6133          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6134      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6135          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6136      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6137          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6138      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6139        enddo
6140 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6141 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6142
6143 C to check gradient call subroutine check_grad
6144
6145     1 continue
6146       enddo
6147       return
6148       end
6149 #endif
6150 c------------------------------------------------------------------------------
6151       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6152 C
6153 C This procedure calculates two-body contact function g(rij) and its derivative:
6154 C
6155 C           eps0ij                                     !       x < -1
6156 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6157 C            0                                         !       x > 1
6158 C
6159 C where x=(rij-r0ij)/delta
6160 C
6161 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6162 C
6163       implicit none
6164       double precision rij,r0ij,eps0ij,fcont,fprimcont
6165       double precision x,x2,x4,delta
6166 c     delta=0.02D0*r0ij
6167 c      delta=0.2D0*r0ij
6168       x=(rij-r0ij)/delta
6169       if (x.lt.-1.0D0) then
6170         fcont=eps0ij
6171         fprimcont=0.0D0
6172       else if (x.le.1.0D0) then
6173         x2=x*x
6174         x4=x2*x2
6175         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6176         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6177       else
6178         fcont=0.0D0
6179         fprimcont=0.0D0
6180       endif
6181       return
6182       end
6183 c------------------------------------------------------------------------------
6184       subroutine splinthet(theti,delta,ss,ssder)
6185       implicit real*8 (a-h,o-z)
6186       include 'DIMENSIONS'
6187       include 'DIMENSIONS.ZSCOPT'
6188       include 'COMMON.VAR'
6189       include 'COMMON.GEO'
6190       thetup=pi-delta
6191       thetlow=delta
6192       if (theti.gt.pipol) then
6193         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6194       else
6195         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6196         ssder=-ssder
6197       endif
6198       return
6199       end
6200 c------------------------------------------------------------------------------
6201       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6202       implicit none
6203       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6204       double precision ksi,ksi2,ksi3,a1,a2,a3
6205       a1=fprim0*delta/(f1-f0)
6206       a2=3.0d0-2.0d0*a1
6207       a3=a1-2.0d0
6208       ksi=(x-x0)/delta
6209       ksi2=ksi*ksi
6210       ksi3=ksi2*ksi
6211       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6212       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6213       return
6214       end
6215 c------------------------------------------------------------------------------
6216       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6217       implicit none
6218       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6219       double precision ksi,ksi2,ksi3,a1,a2,a3
6220       ksi=(x-x0)/delta
6221       ksi2=ksi*ksi
6222       ksi3=ksi2*ksi
6223       a1=fprim0x*delta
6224       a2=3*(f1x-f0x)-2*fprim0x*delta
6225       a3=fprim0x*delta-2*(f1x-f0x)
6226       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6227       return
6228       end
6229 C-----------------------------------------------------------------------------
6230 #ifdef CRYST_TOR
6231 C-----------------------------------------------------------------------------
6232       subroutine etor(etors,fact)
6233       implicit real*8 (a-h,o-z)
6234       include 'DIMENSIONS'
6235       include 'DIMENSIONS.ZSCOPT'
6236       include 'COMMON.VAR'
6237       include 'COMMON.GEO'
6238       include 'COMMON.LOCAL'
6239       include 'COMMON.TORSION'
6240       include 'COMMON.INTERACT'
6241       include 'COMMON.DERIV'
6242       include 'COMMON.CHAIN'
6243       include 'COMMON.NAMES'
6244       include 'COMMON.IOUNITS'
6245       include 'COMMON.FFIELD'
6246       include 'COMMON.TORCNSTR'
6247       logical lprn
6248 C Set lprn=.true. for debugging
6249       lprn=.false.
6250 c      lprn=.true.
6251       etors=0.0D0
6252       do i=iphi_start,iphi_end
6253         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6254      &      .or. itype(i).eq.ntyp1) cycle
6255         itori=itortyp(itype(i-2))
6256         itori1=itortyp(itype(i-1))
6257         phii=phi(i)
6258         gloci=0.0D0
6259 C Proline-Proline pair is a special case...
6260         if (itori.eq.3 .and. itori1.eq.3) then
6261           if (phii.gt.-dwapi3) then
6262             cosphi=dcos(3*phii)
6263             fac=1.0D0/(1.0D0-cosphi)
6264             etorsi=v1(1,3,3)*fac
6265             etorsi=etorsi+etorsi
6266             etors=etors+etorsi-v1(1,3,3)
6267             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6268           endif
6269           do j=1,3
6270             v1ij=v1(j+1,itori,itori1)
6271             v2ij=v2(j+1,itori,itori1)
6272             cosphi=dcos(j*phii)
6273             sinphi=dsin(j*phii)
6274             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6275             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6276           enddo
6277         else
6278           do j=1,nterm_old
6279             v1ij=v1(j,itori,itori1)
6280             v2ij=v2(j,itori,itori1)
6281             cosphi=dcos(j*phii)
6282             sinphi=dsin(j*phii)
6283             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6284             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6285           enddo
6286         endif
6287         if (lprn)
6288      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6289      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6290      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6291         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6292 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6293       enddo
6294       return
6295       end
6296 c------------------------------------------------------------------------------
6297 #else
6298       subroutine etor(etors,fact)
6299       implicit real*8 (a-h,o-z)
6300       include 'DIMENSIONS'
6301       include 'DIMENSIONS.ZSCOPT'
6302       include 'COMMON.VAR'
6303       include 'COMMON.GEO'
6304       include 'COMMON.LOCAL'
6305       include 'COMMON.TORSION'
6306       include 'COMMON.INTERACT'
6307       include 'COMMON.DERIV'
6308       include 'COMMON.CHAIN'
6309       include 'COMMON.NAMES'
6310       include 'COMMON.IOUNITS'
6311       include 'COMMON.FFIELD'
6312       include 'COMMON.TORCNSTR'
6313       logical lprn
6314 C Set lprn=.true. for debugging
6315       lprn=.false.
6316 c      lprn=.true.
6317       etors=0.0D0
6318       do i=iphi_start,iphi_end
6319         if (i.le.2) cycle
6320         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6321      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6322 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6323 C     &       .or. itype(i).eq.ntyp1) cycle
6324         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6325          if (iabs(itype(i)).eq.20) then
6326          iblock=2
6327          else
6328          iblock=1
6329          endif
6330         itori=itortyp(itype(i-2))
6331         itori1=itortyp(itype(i-1))
6332         phii=phi(i)
6333         gloci=0.0D0
6334 C Regular cosine and sine terms
6335         do j=1,nterm(itori,itori1,iblock)
6336           v1ij=v1(j,itori,itori1,iblock)
6337           v2ij=v2(j,itori,itori1,iblock)
6338           cosphi=dcos(j*phii)
6339           sinphi=dsin(j*phii)
6340           etors=etors+v1ij*cosphi+v2ij*sinphi
6341           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6342         enddo
6343 C Lorentz terms
6344 C                         v1
6345 C  E = SUM ----------------------------------- - v1
6346 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6347 C
6348         cosphi=dcos(0.5d0*phii)
6349         sinphi=dsin(0.5d0*phii)
6350         do j=1,nlor(itori,itori1,iblock)
6351           vl1ij=vlor1(j,itori,itori1)
6352           vl2ij=vlor2(j,itori,itori1)
6353           vl3ij=vlor3(j,itori,itori1)
6354           pom=vl2ij*cosphi+vl3ij*sinphi
6355           pom1=1.0d0/(pom*pom+1.0d0)
6356           etors=etors+vl1ij*pom1
6357 c          if (energy_dec) etors_ii=etors_ii+
6358 c     &                vl1ij*pom1
6359           pom=-pom*pom1*pom1
6360           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6361         enddo
6362 C Subtract the constant term
6363         etors=etors-v0(itori,itori1,iblock)
6364         if (lprn)
6365      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6366      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6367      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6368         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6369 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6370  1215   continue
6371       enddo
6372       return
6373       end
6374 c----------------------------------------------------------------------------
6375       subroutine etor_d(etors_d,fact2)
6376 C 6/23/01 Compute double torsional energy
6377       implicit real*8 (a-h,o-z)
6378       include 'DIMENSIONS'
6379       include 'DIMENSIONS.ZSCOPT'
6380       include 'COMMON.VAR'
6381       include 'COMMON.GEO'
6382       include 'COMMON.LOCAL'
6383       include 'COMMON.TORSION'
6384       include 'COMMON.INTERACT'
6385       include 'COMMON.DERIV'
6386       include 'COMMON.CHAIN'
6387       include 'COMMON.NAMES'
6388       include 'COMMON.IOUNITS'
6389       include 'COMMON.FFIELD'
6390       include 'COMMON.TORCNSTR'
6391       logical lprn
6392 C Set lprn=.true. for debugging
6393       lprn=.false.
6394 c     lprn=.true.
6395       etors_d=0.0D0
6396       do i=iphi_start,iphi_end-1
6397         if (i.le.3) cycle
6398 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6399 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6400          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6401      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6402      &  (itype(i+1).eq.ntyp1)) cycle
6403         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6404      &     goto 1215
6405         itori=itortyp(itype(i-2))
6406         itori1=itortyp(itype(i-1))
6407         itori2=itortyp(itype(i))
6408         phii=phi(i)
6409         phii1=phi(i+1)
6410         gloci1=0.0D0
6411         gloci2=0.0D0
6412         iblock=1
6413         if (iabs(itype(i+1)).eq.20) iblock=2
6414 C Regular cosine and sine terms
6415         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6416           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6417           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6418           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6419           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6420           cosphi1=dcos(j*phii)
6421           sinphi1=dsin(j*phii)
6422           cosphi2=dcos(j*phii1)
6423           sinphi2=dsin(j*phii1)
6424           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6425      &     v2cij*cosphi2+v2sij*sinphi2
6426           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6427           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6428         enddo
6429         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6430           do l=1,k-1
6431             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6432             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6433             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6434             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6435             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6436             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6437             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6438             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6439             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6440      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6441             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6442      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6443             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6444      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6445           enddo
6446         enddo
6447         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6448         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6449  1215   continue
6450       enddo
6451       return
6452       end
6453 #endif
6454 c---------------------------------------------------------------------------
6455 C The rigorous attempt to derive energy function
6456       subroutine etor_kcc(etors,fact)
6457       implicit real*8 (a-h,o-z)
6458       include 'DIMENSIONS'
6459       include 'DIMENSIONS.ZSCOPT'
6460       include 'COMMON.VAR'
6461       include 'COMMON.GEO'
6462       include 'COMMON.LOCAL'
6463       include 'COMMON.TORSION'
6464       include 'COMMON.INTERACT'
6465       include 'COMMON.DERIV'
6466       include 'COMMON.CHAIN'
6467       include 'COMMON.NAMES'
6468       include 'COMMON.IOUNITS'
6469       include 'COMMON.FFIELD'
6470       include 'COMMON.TORCNSTR'
6471       include 'COMMON.CONTROL'
6472       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6473       logical lprn
6474 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6475 C Set lprn=.true. for debugging
6476       lprn=energy_dec
6477 c     lprn=.true.
6478 C      print *,"wchodze kcc"
6479       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6480       etors=0.0D0
6481       do i=iphi_start,iphi_end
6482 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6483 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6484 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6485 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6486         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6487      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6488         itori=itortyp(itype(i-2))
6489         itori1=itortyp(itype(i-1))
6490         phii=phi(i)
6491         glocig=0.0D0
6492         glocit1=0.0d0
6493         glocit2=0.0d0
6494 C to avoid multiple devision by 2
6495 c        theti22=0.5d0*theta(i)
6496 C theta 12 is the theta_1 /2
6497 C theta 22 is theta_2 /2
6498 c        theti12=0.5d0*theta(i-1)
6499 C and appropriate sinus function
6500         sinthet1=dsin(theta(i-1))
6501         sinthet2=dsin(theta(i))
6502         costhet1=dcos(theta(i-1))
6503         costhet2=dcos(theta(i))
6504 C to speed up lets store its mutliplication
6505         sint1t2=sinthet2*sinthet1
6506         sint1t2n=1.0d0
6507 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6508 C +d_n*sin(n*gamma)) *
6509 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6510 C we have two sum 1) Non-Chebyshev which is with n and gamma
6511         nval=nterm_kcc_Tb(itori,itori1)
6512         c1(0)=0.0d0
6513         c2(0)=0.0d0
6514         c1(1)=1.0d0
6515         c2(1)=1.0d0
6516         do j=2,nval
6517           c1(j)=c1(j-1)*costhet1
6518           c2(j)=c2(j-1)*costhet2
6519         enddo
6520         etori=0.0d0
6521         do j=1,nterm_kcc(itori,itori1)
6522           cosphi=dcos(j*phii)
6523           sinphi=dsin(j*phii)
6524           sint1t2n1=sint1t2n
6525           sint1t2n=sint1t2n*sint1t2
6526           sumvalc=0.0d0
6527           gradvalct1=0.0d0
6528           gradvalct2=0.0d0
6529           do k=1,nval
6530             do l=1,nval
6531               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6532               gradvalct1=gradvalct1+
6533      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6534               gradvalct2=gradvalct2+
6535      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6536             enddo
6537           enddo
6538           gradvalct1=-gradvalct1*sinthet1
6539           gradvalct2=-gradvalct2*sinthet2
6540           sumvals=0.0d0
6541           gradvalst1=0.0d0
6542           gradvalst2=0.0d0
6543           do k=1,nval
6544             do l=1,nval
6545               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6546               gradvalst1=gradvalst1+
6547      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6548               gradvalst2=gradvalst2+
6549      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6550             enddo
6551           enddo
6552           gradvalst1=-gradvalst1*sinthet1
6553           gradvalst2=-gradvalst2*sinthet2
6554           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6555 C glocig is the gradient local i site in gamma
6556           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6557 C now gradient over theta_1
6558           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6559      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6560           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6561      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6562         enddo ! j
6563         etors=etors+etori
6564 C derivative over gamma
6565         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6566 C derivative over theta1
6567         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6568 C now derivative over theta2
6569         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6570         if (lprn) then
6571           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6572      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6573           write (iout,*) "c1",(c1(k),k=0,nval),
6574      &    " c2",(c2(k),k=0,nval)
6575           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6576         endif
6577       enddo
6578       return
6579       end
6580 c---------------------------------------------------------------------------------------------
6581       subroutine etor_constr(edihcnstr)
6582       implicit real*8 (a-h,o-z)
6583       include 'DIMENSIONS'
6584       include 'DIMENSIONS.ZSCOPT'
6585       include 'COMMON.VAR'
6586       include 'COMMON.GEO'
6587       include 'COMMON.LOCAL'
6588       include 'COMMON.TORSION'
6589       include 'COMMON.INTERACT'
6590       include 'COMMON.DERIV'
6591       include 'COMMON.CHAIN'
6592       include 'COMMON.NAMES'
6593       include 'COMMON.IOUNITS'
6594       include 'COMMON.FFIELD'
6595       include 'COMMON.TORCNSTR'
6596       include 'COMMON.CONTROL'
6597 ! 6/20/98 - dihedral angle constraints
6598       edihcnstr=0.0d0
6599 c      do i=1,ndih_constr
6600 c      write (iout,*) "idihconstr_start",idihconstr_start,
6601 c     &  " idihconstr_end",idihconstr_end
6602
6603       if (raw_psipred) then
6604         do i=idihconstr_start,idihconstr_end
6605           itori=idih_constr(i)
6606           phii=phi(itori)
6607           gaudih_i=vpsipred(1,i)
6608           gauder_i=0.0d0
6609           do j=1,2
6610             s = sdihed(j,i)
6611             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6612             dexpcos_i=dexp(-cos_i*cos_i)
6613             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6614             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6615      &            *cos_i*dexpcos_i/s**2
6616           enddo
6617           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6618           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6619           if (energy_dec)
6620      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6621      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6622      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6623      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6624      &     -wdihc*dlog(gaudih_i)
6625         enddo
6626       else
6627
6628       do i=idihconstr_start,idihconstr_end
6629         itori=idih_constr(i)
6630         phii=phi(itori)
6631         difi=pinorm(phii-phi0(i))
6632         if (difi.gt.drange(i)) then
6633           difi=difi-drange(i)
6634           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6635           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6636         else if (difi.lt.-drange(i)) then
6637           difi=difi+drange(i)
6638           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6639           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6640         else
6641           difi=0.0
6642         endif
6643       enddo
6644
6645       endif
6646
6647 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6648       return
6649       end
6650 c----------------------------------------------------------------------------
6651 C The rigorous attempt to derive energy function
6652       subroutine ebend_kcc(etheta)
6653
6654       implicit real*8 (a-h,o-z)
6655       include 'DIMENSIONS'
6656       include 'DIMENSIONS.ZSCOPT'
6657       include 'COMMON.VAR'
6658       include 'COMMON.GEO'
6659       include 'COMMON.LOCAL'
6660       include 'COMMON.TORSION'
6661       include 'COMMON.INTERACT'
6662       include 'COMMON.DERIV'
6663       include 'COMMON.CHAIN'
6664       include 'COMMON.NAMES'
6665       include 'COMMON.IOUNITS'
6666       include 'COMMON.FFIELD'
6667       include 'COMMON.TORCNSTR'
6668       include 'COMMON.CONTROL'
6669       logical lprn
6670       double precision thybt1(maxang_kcc)
6671 C Set lprn=.true. for debugging
6672       lprn=energy_dec
6673 c     lprn=.true.
6674 C      print *,"wchodze kcc"
6675       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6676       etheta=0.0D0
6677       do i=ithet_start,ithet_end
6678 c        print *,i,itype(i-1),itype(i),itype(i-2)
6679         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6680      &  .or.itype(i).eq.ntyp1) cycle
6681         iti=iabs(itortyp(itype(i-1)))
6682         sinthet=dsin(theta(i))
6683         costhet=dcos(theta(i))
6684         do j=1,nbend_kcc_Tb(iti)
6685           thybt1(j)=v1bend_chyb(j,iti)
6686         enddo
6687         sumth1thyb=v1bend_chyb(0,iti)+
6688      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6689         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6690      &    sumth1thyb
6691         ihelp=nbend_kcc_Tb(iti)-1
6692         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6693         etheta=etheta+sumth1thyb
6694 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6695         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6696       enddo
6697       return
6698       end
6699 c-------------------------------------------------------------------------------------
6700       subroutine etheta_constr(ethetacnstr)
6701
6702       implicit real*8 (a-h,o-z)
6703       include 'DIMENSIONS'
6704       include 'DIMENSIONS.ZSCOPT'
6705       include 'COMMON.VAR'
6706       include 'COMMON.GEO'
6707       include 'COMMON.LOCAL'
6708       include 'COMMON.TORSION'
6709       include 'COMMON.INTERACT'
6710       include 'COMMON.DERIV'
6711       include 'COMMON.CHAIN'
6712       include 'COMMON.NAMES'
6713       include 'COMMON.IOUNITS'
6714       include 'COMMON.FFIELD'
6715       include 'COMMON.TORCNSTR'
6716       include 'COMMON.CONTROL'
6717       ethetacnstr=0.0d0
6718 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6719       do i=ithetaconstr_start,ithetaconstr_end
6720         itheta=itheta_constr(i)
6721         thetiii=theta(itheta)
6722         difi=pinorm(thetiii-theta_constr0(i))
6723         if (difi.gt.theta_drange(i)) then
6724           difi=difi-theta_drange(i)
6725           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6726           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6727      &    +for_thet_constr(i)*difi**3
6728         else if (difi.lt.-drange(i)) then
6729           difi=difi+drange(i)
6730           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6731           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6732      &    +for_thet_constr(i)*difi**3
6733         else
6734           difi=0.0
6735         endif
6736        if (energy_dec) then
6737         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6738      &    i,itheta,rad2deg*thetiii,
6739      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6740      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6741      &    gloc(itheta+nphi-2,icg)
6742         endif
6743       enddo
6744       return
6745       end
6746 c------------------------------------------------------------------------------
6747 c------------------------------------------------------------------------------
6748       subroutine eback_sc_corr(esccor)
6749 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6750 c        conformational states; temporarily implemented as differences
6751 c        between UNRES torsional potentials (dependent on three types of
6752 c        residues) and the torsional potentials dependent on all 20 types
6753 c        of residues computed from AM1 energy surfaces of terminally-blocked
6754 c        amino-acid residues.
6755       implicit real*8 (a-h,o-z)
6756       include 'DIMENSIONS'
6757       include 'DIMENSIONS.ZSCOPT'
6758       include 'COMMON.VAR'
6759       include 'COMMON.GEO'
6760       include 'COMMON.LOCAL'
6761       include 'COMMON.TORSION'
6762       include 'COMMON.SCCOR'
6763       include 'COMMON.INTERACT'
6764       include 'COMMON.DERIV'
6765       include 'COMMON.CHAIN'
6766       include 'COMMON.NAMES'
6767       include 'COMMON.IOUNITS'
6768       include 'COMMON.FFIELD'
6769       include 'COMMON.CONTROL'
6770       logical lprn
6771 C Set lprn=.true. for debugging
6772       lprn=.false.
6773 c      lprn=.true.
6774 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6775       esccor=0.0D0
6776       do i=itau_start,itau_end
6777         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6778         esccor_ii=0.0D0
6779         isccori=isccortyp(itype(i-2))
6780         isccori1=isccortyp(itype(i-1))
6781         phii=phi(i)
6782         do intertyp=1,3 !intertyp
6783 cc Added 09 May 2012 (Adasko)
6784 cc  Intertyp means interaction type of backbone mainchain correlation:
6785 c   1 = SC...Ca...Ca...Ca
6786 c   2 = Ca...Ca...Ca...SC
6787 c   3 = SC...Ca...Ca...SCi
6788         gloci=0.0D0
6789         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6790      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6791      &      (itype(i-1).eq.ntyp1)))
6792      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6793      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6794      &     .or.(itype(i).eq.ntyp1)))
6795      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6796      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6797      &      (itype(i-3).eq.ntyp1)))) cycle
6798         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6799         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6800      & cycle
6801        do j=1,nterm_sccor(isccori,isccori1)
6802           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6803           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6804           cosphi=dcos(j*tauangle(intertyp,i))
6805           sinphi=dsin(j*tauangle(intertyp,i))
6806            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6807            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6808          enddo
6809 C      write (iout,*)"EBACK_SC_COR",esccor,i
6810 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6811 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6812 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6813         if (lprn)
6814      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6815      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6816      &  (v1sccor(j,1,itori,itori1),j=1,6)
6817      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6818 c        gsccor_loc(i-3)=gloci
6819        enddo !intertyp
6820       enddo
6821       return
6822       end
6823 #ifdef FOURBODY
6824 c------------------------------------------------------------------------------
6825       subroutine multibody(ecorr)
6826 C This subroutine calculates multi-body contributions to energy following
6827 C the idea of Skolnick et al. If side chains I and J make a contact and
6828 C at the same time side chains I+1 and J+1 make a contact, an extra
6829 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6830       implicit real*8 (a-h,o-z)
6831       include 'DIMENSIONS'
6832       include 'COMMON.IOUNITS'
6833       include 'COMMON.DERIV'
6834       include 'COMMON.INTERACT'
6835       include 'COMMON.CONTACTS'
6836       include 'COMMON.CONTMAT'
6837       include 'COMMON.CORRMAT'
6838       double precision gx(3),gx1(3)
6839       logical lprn
6840
6841 C Set lprn=.true. for debugging
6842       lprn=.false.
6843
6844       if (lprn) then
6845         write (iout,'(a)') 'Contact function values:'
6846         do i=nnt,nct-2
6847           write (iout,'(i2,20(1x,i2,f10.5))')
6848      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6849         enddo
6850       endif
6851       ecorr=0.0D0
6852       do i=nnt,nct
6853         do j=1,3
6854           gradcorr(j,i)=0.0D0
6855           gradxorr(j,i)=0.0D0
6856         enddo
6857       enddo
6858       do i=nnt,nct-2
6859
6860         DO ISHIFT = 3,4
6861
6862         i1=i+ishift
6863         num_conti=num_cont(i)
6864         num_conti1=num_cont(i1)
6865         do jj=1,num_conti
6866           j=jcont(jj,i)
6867           do kk=1,num_conti1
6868             j1=jcont(kk,i1)
6869             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6870 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6871 cd   &                   ' ishift=',ishift
6872 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6873 C The system gains extra energy.
6874               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6875             endif   ! j1==j+-ishift
6876           enddo     ! kk
6877         enddo       ! jj
6878
6879         ENDDO ! ISHIFT
6880
6881       enddo         ! i
6882       return
6883       end
6884 c------------------------------------------------------------------------------
6885       double precision function esccorr(i,j,k,l,jj,kk)
6886       implicit real*8 (a-h,o-z)
6887       include 'DIMENSIONS'
6888       include 'COMMON.IOUNITS'
6889       include 'COMMON.DERIV'
6890       include 'COMMON.INTERACT'
6891       include 'COMMON.CONTACTS'
6892       include 'COMMON.CONTMAT'
6893       include 'COMMON.CORRMAT'
6894       double precision gx(3),gx1(3)
6895       logical lprn
6896       lprn=.false.
6897       eij=facont(jj,i)
6898       ekl=facont(kk,k)
6899 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6900 C Calculate the multi-body contribution to energy.
6901 C Calculate multi-body contributions to the gradient.
6902 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6903 cd   & k,l,(gacont(m,kk,k),m=1,3)
6904       do m=1,3
6905         gx(m) =ekl*gacont(m,jj,i)
6906         gx1(m)=eij*gacont(m,kk,k)
6907         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6908         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6909         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6910         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6911       enddo
6912       do m=i,j-1
6913         do ll=1,3
6914           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6915         enddo
6916       enddo
6917       do m=k,l-1
6918         do ll=1,3
6919           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6920         enddo
6921       enddo
6922       esccorr=-eij*ekl
6923       return
6924       end
6925 c------------------------------------------------------------------------------
6926       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6927 C This subroutine calculates multi-body contributions to hydrogen-bonding
6928       implicit real*8 (a-h,o-z)
6929       include 'DIMENSIONS'
6930       include 'DIMENSIONS.ZSCOPT'
6931       include 'COMMON.IOUNITS'
6932       include 'COMMON.FFIELD'
6933       include 'COMMON.DERIV'
6934       include 'COMMON.INTERACT'
6935       include 'COMMON.CONTACTS'
6936       include 'COMMON.CONTMAT'
6937       include 'COMMON.CORRMAT'
6938       double precision gx(3),gx1(3)
6939       logical lprn,ldone
6940
6941 C Set lprn=.true. for debugging
6942       lprn=.false.
6943       if (lprn) then
6944         write (iout,'(a)') 'Contact function values:'
6945         do i=nnt,nct-2
6946           write (iout,'(2i3,50(1x,i2,f5.2))')
6947      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6948      &    j=1,num_cont_hb(i))
6949         enddo
6950       endif
6951       ecorr=0.0D0
6952 C Remove the loop below after debugging !!!
6953       do i=nnt,nct
6954         do j=1,3
6955           gradcorr(j,i)=0.0D0
6956           gradxorr(j,i)=0.0D0
6957         enddo
6958       enddo
6959 C Calculate the local-electrostatic correlation terms
6960       do i=iatel_s,iatel_e+1
6961         i1=i+1
6962         num_conti=num_cont_hb(i)
6963         num_conti1=num_cont_hb(i+1)
6964         do jj=1,num_conti
6965           j=jcont_hb(jj,i)
6966           do kk=1,num_conti1
6967             j1=jcont_hb(kk,i1)
6968 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6969 c     &         ' jj=',jj,' kk=',kk
6970             if (j1.eq.j+1 .or. j1.eq.j-1) then
6971 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6972 C The system gains extra energy.
6973               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6974               n_corr=n_corr+1
6975             else if (j1.eq.j) then
6976 C Contacts I-J and I-(J+1) occur simultaneously.
6977 C The system loses extra energy.
6978 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6979             endif
6980           enddo ! kk
6981           do kk=1,num_conti
6982             j1=jcont_hb(kk,i)
6983 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6984 c    &         ' jj=',jj,' kk=',kk
6985             if (j1.eq.j+1) then
6986 C Contacts I-J and (I+1)-J occur simultaneously.
6987 C The system loses extra energy.
6988 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6989             endif ! j1==j+1
6990           enddo ! kk
6991         enddo ! jj
6992       enddo ! i
6993       return
6994       end
6995 c------------------------------------------------------------------------------
6996       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6997      &  n_corr1)
6998 C This subroutine calculates multi-body contributions to hydrogen-bonding
6999       implicit real*8 (a-h,o-z)
7000       include 'DIMENSIONS'
7001       include 'DIMENSIONS.ZSCOPT'
7002       include 'COMMON.IOUNITS'
7003 #ifdef MPI
7004       include "mpif.h"
7005 #endif
7006       include 'COMMON.FFIELD'
7007       include 'COMMON.DERIV'
7008       include 'COMMON.LOCAL'
7009       include 'COMMON.INTERACT'
7010       include 'COMMON.CONTACTS'
7011       include 'COMMON.CONTMAT'
7012       include 'COMMON.CORRMAT'
7013       include 'COMMON.CHAIN'
7014       include 'COMMON.CONTROL'
7015       include 'COMMON.SHIELD'
7016       double precision gx(3),gx1(3)
7017       integer num_cont_hb_old(maxres)
7018       logical lprn,ldone
7019       double precision eello4,eello5,eelo6,eello_turn6
7020       external eello4,eello5,eello6,eello_turn6
7021 C Set lprn=.true. for debugging
7022       lprn=.false.
7023       eturn6=0.0d0
7024       if (lprn) then
7025         write (iout,'(a)') 'Contact function values:'
7026         do i=nnt,nct-2
7027           write (iout,'(2i3,50(1x,i2,5f6.3))')
7028      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7029      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7030         enddo
7031       endif
7032       ecorr=0.0D0
7033       ecorr5=0.0d0
7034       ecorr6=0.0d0
7035 C Remove the loop below after debugging !!!
7036       do i=nnt,nct
7037         do j=1,3
7038           gradcorr(j,i)=0.0D0
7039           gradxorr(j,i)=0.0D0
7040         enddo
7041       enddo
7042 C Calculate the dipole-dipole interaction energies
7043       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7044       do i=iatel_s,iatel_e+1
7045         num_conti=num_cont_hb(i)
7046         do jj=1,num_conti
7047           j=jcont_hb(jj,i)
7048 #ifdef MOMENT
7049           call dipole(i,j,jj)
7050 #endif
7051         enddo
7052       enddo
7053       endif
7054 C Calculate the local-electrostatic correlation terms
7055 c                write (iout,*) "gradcorr5 in eello5 before loop"
7056 c                do iii=1,nres
7057 c                  write (iout,'(i5,3f10.5)')
7058 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7059 c                enddo
7060       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7061 c        write (iout,*) "corr loop i",i
7062         i1=i+1
7063         num_conti=num_cont_hb(i)
7064         num_conti1=num_cont_hb(i+1)
7065         do jj=1,num_conti
7066           j=jcont_hb(jj,i)
7067           jp=iabs(j)
7068           do kk=1,num_conti1
7069             j1=jcont_hb(kk,i1)
7070             jp1=iabs(j1)
7071 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7072 c     &         ' jj=',jj,' kk=',kk
7073 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7074             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7075      &          .or. j.lt.0 .and. j1.gt.0) .and.
7076      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7077 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7078 C The system gains extra energy.
7079               n_corr=n_corr+1
7080               sqd1=dsqrt(d_cont(jj,i))
7081               sqd2=dsqrt(d_cont(kk,i1))
7082               sred_geom = sqd1*sqd2
7083               IF (sred_geom.lt.cutoff_corr) THEN
7084                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7085      &            ekont,fprimcont)
7086 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7087 cd     &         ' jj=',jj,' kk=',kk
7088                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7089                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7090                 do l=1,3
7091                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7092                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7093                 enddo
7094                 n_corr1=n_corr1+1
7095 cd               write (iout,*) 'sred_geom=',sred_geom,
7096 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7097 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7098 cd               write (iout,*) "g_contij",g_contij
7099 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7100 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7101                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7102                 if (wcorr4.gt.0.0d0)
7103      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7104 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7105                   if (energy_dec.and.wcorr4.gt.0.0d0)
7106      1                 write (iout,'(a6,4i5,0pf7.3)')
7107      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7108 c                write (iout,*) "gradcorr5 before eello5"
7109 c                do iii=1,nres
7110 c                  write (iout,'(i5,3f10.5)')
7111 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7112 c                enddo
7113                 if (wcorr5.gt.0.0d0)
7114      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7115 c                write (iout,*) "gradcorr5 after eello5"
7116 c                do iii=1,nres
7117 c                  write (iout,'(i5,3f10.5)')
7118 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7119 c                enddo
7120                   if (energy_dec.and.wcorr5.gt.0.0d0)
7121      1                 write (iout,'(a6,4i5,0pf7.3)')
7122      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7123 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7124 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7125                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7126      &               .or. wturn6.eq.0.0d0))then
7127 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7128                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7129                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7130      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7131 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7132 cd     &            'ecorr6=',ecorr6
7133 cd                write (iout,'(4e15.5)') sred_geom,
7134 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7135 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7136 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7137                 else if (wturn6.gt.0.0d0
7138      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7139 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7140                   eturn6=eturn6+eello_turn6(i,jj,kk)
7141                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7142      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7143 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7144                 endif
7145               ENDIF
7146 1111          continue
7147             endif
7148           enddo ! kk
7149         enddo ! jj
7150       enddo ! i
7151       do i=1,nres
7152         num_cont_hb(i)=num_cont_hb_old(i)
7153       enddo
7154 c                write (iout,*) "gradcorr5 in eello5"
7155 c                do iii=1,nres
7156 c                  write (iout,'(i5,3f10.5)')
7157 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7158 c                enddo
7159       return
7160       end
7161 c------------------------------------------------------------------------------
7162       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7163       implicit real*8 (a-h,o-z)
7164       include 'DIMENSIONS'
7165       include 'DIMENSIONS.ZSCOPT'
7166       include 'COMMON.IOUNITS'
7167       include 'COMMON.DERIV'
7168       include 'COMMON.INTERACT'
7169       include 'COMMON.CONTACTS'
7170       include 'COMMON.CONTMAT'
7171       include 'COMMON.CORRMAT'
7172       include 'COMMON.SHIELD'
7173       include 'COMMON.CONTROL'
7174       double precision gx(3),gx1(3)
7175       logical lprn
7176       lprn=.false.
7177 C      print *,"wchodze",fac_shield(i),shield_mode
7178       eij=facont_hb(jj,i)
7179       ekl=facont_hb(kk,k)
7180       ees0pij=ees0p(jj,i)
7181       ees0pkl=ees0p(kk,k)
7182       ees0mij=ees0m(jj,i)
7183       ees0mkl=ees0m(kk,k)
7184       ekont=eij*ekl
7185       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7186 C*
7187 C     & fac_shield(i)**2*fac_shield(j)**2
7188 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7189 C Following 4 lines for diagnostics.
7190 cd    ees0pkl=0.0D0
7191 cd    ees0pij=1.0D0
7192 cd    ees0mkl=0.0D0
7193 cd    ees0mij=1.0D0
7194 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7195 c     & 'Contacts ',i,j,
7196 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7197 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7198 c     & 'gradcorr_long'
7199 C Calculate the multi-body contribution to energy.
7200 C      ecorr=ecorr+ekont*ees
7201 C Calculate multi-body contributions to the gradient.
7202       coeffpees0pij=coeffp*ees0pij
7203       coeffmees0mij=coeffm*ees0mij
7204       coeffpees0pkl=coeffp*ees0pkl
7205       coeffmees0mkl=coeffm*ees0mkl
7206       do ll=1,3
7207 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7208         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7209      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7210      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7211         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7212      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7213      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7214 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7215         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7216      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7217      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7218         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7219      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7220      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7221         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7222      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7223      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7224         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7225         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7226         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7227      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7228      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7229         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7230         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7231 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7232       enddo
7233 c      write (iout,*)
7234 cgrad      do m=i+1,j-1
7235 cgrad        do ll=1,3
7236 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7237 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7238 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7239 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7240 cgrad        enddo
7241 cgrad      enddo
7242 cgrad      do m=k+1,l-1
7243 cgrad        do ll=1,3
7244 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7245 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7246 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7247 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7248 cgrad        enddo
7249 cgrad      enddo
7250 c      write (iout,*) "ehbcorr",ekont*ees
7251 C      print *,ekont,ees,i,k
7252       ehbcorr=ekont*ees
7253 C now gradient over shielding
7254 C      return
7255       if (shield_mode.gt.0) then
7256        j=ees0plist(jj,i)
7257        l=ees0plist(kk,k)
7258 C        print *,i,j,fac_shield(i),fac_shield(j),
7259 C     &fac_shield(k),fac_shield(l)
7260         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7261      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7262           do ilist=1,ishield_list(i)
7263            iresshield=shield_list(ilist,i)
7264            do m=1,3
7265            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7266 C     &      *2.0
7267            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7268      &              rlocshield
7269      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7270             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7271      &+rlocshield
7272            enddo
7273           enddo
7274           do ilist=1,ishield_list(j)
7275            iresshield=shield_list(ilist,j)
7276            do m=1,3
7277            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7278 C     &     *2.0
7279            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7280      &              rlocshield
7281      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7282            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7283      &     +rlocshield
7284            enddo
7285           enddo
7286
7287           do ilist=1,ishield_list(k)
7288            iresshield=shield_list(ilist,k)
7289            do m=1,3
7290            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7291 C     &     *2.0
7292            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7293      &              rlocshield
7294      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7295            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7296      &     +rlocshield
7297            enddo
7298           enddo
7299           do ilist=1,ishield_list(l)
7300            iresshield=shield_list(ilist,l)
7301            do m=1,3
7302            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7303 C     &     *2.0
7304            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7305      &              rlocshield
7306      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7307            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7308      &     +rlocshield
7309            enddo
7310           enddo
7311 C          print *,gshieldx(m,iresshield)
7312           do m=1,3
7313             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7314      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7315             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7316      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7317             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7318      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7319             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7320      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7321
7322             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7323      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7324             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7325      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7326             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7327      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7328             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7329      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7330
7331            enddo
7332       endif
7333       endif
7334       return
7335       end
7336 #ifdef MOMENT
7337 C---------------------------------------------------------------------------
7338       subroutine dipole(i,j,jj)
7339       implicit real*8 (a-h,o-z)
7340       include 'DIMENSIONS'
7341       include 'DIMENSIONS.ZSCOPT'
7342       include 'COMMON.IOUNITS'
7343       include 'COMMON.CHAIN'
7344       include 'COMMON.FFIELD'
7345       include 'COMMON.DERIV'
7346       include 'COMMON.INTERACT'
7347       include 'COMMON.CONTACTS'
7348       include 'COMMON.CONTMAT'
7349       include 'COMMON.CORRMAT'
7350       include 'COMMON.TORSION'
7351       include 'COMMON.VAR'
7352       include 'COMMON.GEO'
7353       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7354      &  auxmat(2,2)
7355       iti1 = itortyp(itype(i+1))
7356       if (j.lt.nres-1) then
7357         itj1 = itype2loc(itype(j+1))
7358       else
7359         itj1=nloctyp
7360       endif
7361       do iii=1,2
7362         dipi(iii,1)=Ub2(iii,i)
7363         dipderi(iii)=Ub2der(iii,i)
7364         dipi(iii,2)=b1(iii,i+1)
7365         dipj(iii,1)=Ub2(iii,j)
7366         dipderj(iii)=Ub2der(iii,j)
7367         dipj(iii,2)=b1(iii,j+1)
7368       enddo
7369       kkk=0
7370       do iii=1,2
7371         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7372         do jjj=1,2
7373           kkk=kkk+1
7374           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7375         enddo
7376       enddo
7377       do kkk=1,5
7378         do lll=1,3
7379           mmm=0
7380           do iii=1,2
7381             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7382      &        auxvec(1))
7383             do jjj=1,2
7384               mmm=mmm+1
7385               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7386             enddo
7387           enddo
7388         enddo
7389       enddo
7390       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7391       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7392       do iii=1,2
7393         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7394       enddo
7395       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7396       do iii=1,2
7397         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7398       enddo
7399       return
7400       end
7401 #endif
7402 C---------------------------------------------------------------------------
7403       subroutine calc_eello(i,j,k,l,jj,kk)
7404 C
7405 C This subroutine computes matrices and vectors needed to calculate
7406 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7407 C
7408       implicit real*8 (a-h,o-z)
7409       include 'DIMENSIONS'
7410       include 'DIMENSIONS.ZSCOPT'
7411       include 'COMMON.IOUNITS'
7412       include 'COMMON.CHAIN'
7413       include 'COMMON.DERIV'
7414       include 'COMMON.INTERACT'
7415       include 'COMMON.CONTACTS'
7416       include 'COMMON.CONTMAT'
7417       include 'COMMON.CORRMAT'
7418       include 'COMMON.TORSION'
7419       include 'COMMON.VAR'
7420       include 'COMMON.GEO'
7421       include 'COMMON.FFIELD'
7422       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7423      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7424       logical lprn
7425       common /kutas/ lprn
7426 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7427 cd     & ' jj=',jj,' kk=',kk
7428 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7429 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7430 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7431       do iii=1,2
7432         do jjj=1,2
7433           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7434           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7435         enddo
7436       enddo
7437       call transpose2(aa1(1,1),aa1t(1,1))
7438       call transpose2(aa2(1,1),aa2t(1,1))
7439       do kkk=1,5
7440         do lll=1,3
7441           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7442      &      aa1tder(1,1,lll,kkk))
7443           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7444      &      aa2tder(1,1,lll,kkk))
7445         enddo
7446       enddo
7447       if (l.eq.j+1) then
7448 C parallel orientation of the two CA-CA-CA frames.
7449         if (i.gt.1) then
7450           iti=itype2loc(itype(i))
7451         else
7452           iti=nloctyp
7453         endif
7454         itk1=itype2loc(itype(k+1))
7455         itj=itype2loc(itype(j))
7456         if (l.lt.nres-1) then
7457           itl1=itype2loc(itype(l+1))
7458         else
7459           itl1=nloctyp
7460         endif
7461 C A1 kernel(j+1) A2T
7462 cd        do iii=1,2
7463 cd          write (iout,'(3f10.5,5x,3f10.5)')
7464 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7465 cd        enddo
7466         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7467      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7468      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7469 C Following matrices are needed only for 6-th order cumulants
7470         IF (wcorr6.gt.0.0d0) THEN
7471         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7472      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7473      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7474         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7475      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7476      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7477      &   ADtEAderx(1,1,1,1,1,1))
7478         lprn=.false.
7479         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7480      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7481      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7482      &   ADtEA1derx(1,1,1,1,1,1))
7483         ENDIF
7484 C End 6-th order cumulants
7485 cd        lprn=.false.
7486 cd        if (lprn) then
7487 cd        write (2,*) 'In calc_eello6'
7488 cd        do iii=1,2
7489 cd          write (2,*) 'iii=',iii
7490 cd          do kkk=1,5
7491 cd            write (2,*) 'kkk=',kkk
7492 cd            do jjj=1,2
7493 cd              write (2,'(3(2f10.5),5x)')
7494 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7495 cd            enddo
7496 cd          enddo
7497 cd        enddo
7498 cd        endif
7499         call transpose2(EUgder(1,1,k),auxmat(1,1))
7500         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7501         call transpose2(EUg(1,1,k),auxmat(1,1))
7502         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7503         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7504         do iii=1,2
7505           do kkk=1,5
7506             do lll=1,3
7507               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7508      &          EAEAderx(1,1,lll,kkk,iii,1))
7509             enddo
7510           enddo
7511         enddo
7512 C A1T kernel(i+1) A2
7513         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7514      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7515      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7516 C Following matrices are needed only for 6-th order cumulants
7517         IF (wcorr6.gt.0.0d0) THEN
7518         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7519      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7520      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7521         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7522      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7523      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7524      &   ADtEAderx(1,1,1,1,1,2))
7525         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7526      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7527      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7528      &   ADtEA1derx(1,1,1,1,1,2))
7529         ENDIF
7530 C End 6-th order cumulants
7531         call transpose2(EUgder(1,1,l),auxmat(1,1))
7532         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7533         call transpose2(EUg(1,1,l),auxmat(1,1))
7534         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7535         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7536         do iii=1,2
7537           do kkk=1,5
7538             do lll=1,3
7539               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7540      &          EAEAderx(1,1,lll,kkk,iii,2))
7541             enddo
7542           enddo
7543         enddo
7544 C AEAb1 and AEAb2
7545 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7546 C They are needed only when the fifth- or the sixth-order cumulants are
7547 C indluded.
7548         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7549         call transpose2(AEA(1,1,1),auxmat(1,1))
7550         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7551         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7552         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7553         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7554         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7555         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7556         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7557         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7558         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7559         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7560         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7561         call transpose2(AEA(1,1,2),auxmat(1,1))
7562         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7563         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7564         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7565         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7566         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7567         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7568         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7569         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7570         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7571         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7572         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7573 C Calculate the Cartesian derivatives of the vectors.
7574         do iii=1,2
7575           do kkk=1,5
7576             do lll=1,3
7577               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7578               call matvec2(auxmat(1,1),b1(1,i),
7579      &          AEAb1derx(1,lll,kkk,iii,1,1))
7580               call matvec2(auxmat(1,1),Ub2(1,i),
7581      &          AEAb2derx(1,lll,kkk,iii,1,1))
7582               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7583      &          AEAb1derx(1,lll,kkk,iii,2,1))
7584               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7585      &          AEAb2derx(1,lll,kkk,iii,2,1))
7586               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7587               call matvec2(auxmat(1,1),b1(1,j),
7588      &          AEAb1derx(1,lll,kkk,iii,1,2))
7589               call matvec2(auxmat(1,1),Ub2(1,j),
7590      &          AEAb2derx(1,lll,kkk,iii,1,2))
7591               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7592      &          AEAb1derx(1,lll,kkk,iii,2,2))
7593               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7594      &          AEAb2derx(1,lll,kkk,iii,2,2))
7595             enddo
7596           enddo
7597         enddo
7598         ENDIF
7599 C End vectors
7600       else
7601 C Antiparallel orientation of the two CA-CA-CA frames.
7602         if (i.gt.1) then
7603           iti=itype2loc(itype(i))
7604         else
7605           iti=nloctyp
7606         endif
7607         itk1=itype2loc(itype(k+1))
7608         itl=itype2loc(itype(l))
7609         itj=itype2loc(itype(j))
7610         if (j.lt.nres-1) then
7611           itj1=itype2loc(itype(j+1))
7612         else
7613           itj1=nloctyp
7614         endif
7615 C A2 kernel(j-1)T A1T
7616         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7617      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7618      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7619 C Following matrices are needed only for 6-th order cumulants
7620         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7621      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7622         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7623      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7624      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7625         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7626      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7627      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7628      &   ADtEAderx(1,1,1,1,1,1))
7629         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7630      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7631      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7632      &   ADtEA1derx(1,1,1,1,1,1))
7633         ENDIF
7634 C End 6-th order cumulants
7635         call transpose2(EUgder(1,1,k),auxmat(1,1))
7636         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7637         call transpose2(EUg(1,1,k),auxmat(1,1))
7638         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7639         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7640         do iii=1,2
7641           do kkk=1,5
7642             do lll=1,3
7643               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7644      &          EAEAderx(1,1,lll,kkk,iii,1))
7645             enddo
7646           enddo
7647         enddo
7648 C A2T kernel(i+1)T A1
7649         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7650      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7651      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7652 C Following matrices are needed only for 6-th order cumulants
7653         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7654      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7655         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7656      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7657      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7658         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7659      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7660      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7661      &   ADtEAderx(1,1,1,1,1,2))
7662         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7663      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7664      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7665      &   ADtEA1derx(1,1,1,1,1,2))
7666         ENDIF
7667 C End 6-th order cumulants
7668         call transpose2(EUgder(1,1,j),auxmat(1,1))
7669         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7670         call transpose2(EUg(1,1,j),auxmat(1,1))
7671         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7672         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7673         do iii=1,2
7674           do kkk=1,5
7675             do lll=1,3
7676               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7677      &          EAEAderx(1,1,lll,kkk,iii,2))
7678             enddo
7679           enddo
7680         enddo
7681 C AEAb1 and AEAb2
7682 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7683 C They are needed only when the fifth- or the sixth-order cumulants are
7684 C indluded.
7685         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7686      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7687         call transpose2(AEA(1,1,1),auxmat(1,1))
7688         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7689         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7690         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7691         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7692         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7693         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7694         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7695         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7696         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7697         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7698         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7699         call transpose2(AEA(1,1,2),auxmat(1,1))
7700         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7701         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7702         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7703         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7704         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7705         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7706         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7707         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7708         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7709         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7710         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7711 C Calculate the Cartesian derivatives of the vectors.
7712         do iii=1,2
7713           do kkk=1,5
7714             do lll=1,3
7715               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7716               call matvec2(auxmat(1,1),b1(1,i),
7717      &          AEAb1derx(1,lll,kkk,iii,1,1))
7718               call matvec2(auxmat(1,1),Ub2(1,i),
7719      &          AEAb2derx(1,lll,kkk,iii,1,1))
7720               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7721      &          AEAb1derx(1,lll,kkk,iii,2,1))
7722               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7723      &          AEAb2derx(1,lll,kkk,iii,2,1))
7724               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7725               call matvec2(auxmat(1,1),b1(1,l),
7726      &          AEAb1derx(1,lll,kkk,iii,1,2))
7727               call matvec2(auxmat(1,1),Ub2(1,l),
7728      &          AEAb2derx(1,lll,kkk,iii,1,2))
7729               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7730      &          AEAb1derx(1,lll,kkk,iii,2,2))
7731               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7732      &          AEAb2derx(1,lll,kkk,iii,2,2))
7733             enddo
7734           enddo
7735         enddo
7736         ENDIF
7737 C End vectors
7738       endif
7739       return
7740       end
7741 C---------------------------------------------------------------------------
7742       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7743      &  KK,KKderg,AKA,AKAderg,AKAderx)
7744       implicit none
7745       integer nderg
7746       logical transp
7747       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7748      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7749      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7750       integer iii,kkk,lll
7751       integer jjj,mmm
7752       logical lprn
7753       common /kutas/ lprn
7754       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7755       do iii=1,nderg
7756         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7757      &    AKAderg(1,1,iii))
7758       enddo
7759 cd      if (lprn) write (2,*) 'In kernel'
7760       do kkk=1,5
7761 cd        if (lprn) write (2,*) 'kkk=',kkk
7762         do lll=1,3
7763           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7764      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7765 cd          if (lprn) then
7766 cd            write (2,*) 'lll=',lll
7767 cd            write (2,*) 'iii=1'
7768 cd            do jjj=1,2
7769 cd              write (2,'(3(2f10.5),5x)')
7770 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7771 cd            enddo
7772 cd          endif
7773           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7774      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7775 cd          if (lprn) then
7776 cd            write (2,*) 'lll=',lll
7777 cd            write (2,*) 'iii=2'
7778 cd            do jjj=1,2
7779 cd              write (2,'(3(2f10.5),5x)')
7780 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7781 cd            enddo
7782 cd          endif
7783         enddo
7784       enddo
7785       return
7786       end
7787 C---------------------------------------------------------------------------
7788       double precision function eello4(i,j,k,l,jj,kk)
7789       implicit real*8 (a-h,o-z)
7790       include 'DIMENSIONS'
7791       include 'DIMENSIONS.ZSCOPT'
7792       include 'COMMON.IOUNITS'
7793       include 'COMMON.CHAIN'
7794       include 'COMMON.DERIV'
7795       include 'COMMON.INTERACT'
7796       include 'COMMON.CONTACTS'
7797       include 'COMMON.CONTMAT'
7798       include 'COMMON.CORRMAT'
7799       include 'COMMON.TORSION'
7800       include 'COMMON.VAR'
7801       include 'COMMON.GEO'
7802       double precision pizda(2,2),ggg1(3),ggg2(3)
7803 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7804 cd        eello4=0.0d0
7805 cd        return
7806 cd      endif
7807 cd      print *,'eello4:',i,j,k,l,jj,kk
7808 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7809 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7810 cold      eij=facont_hb(jj,i)
7811 cold      ekl=facont_hb(kk,k)
7812 cold      ekont=eij*ekl
7813       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7814       if (calc_grad) then
7815 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7816       gcorr_loc(k-1)=gcorr_loc(k-1)
7817      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7818       if (l.eq.j+1) then
7819         gcorr_loc(l-1)=gcorr_loc(l-1)
7820      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7821       else
7822         gcorr_loc(j-1)=gcorr_loc(j-1)
7823      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7824       endif
7825       do iii=1,2
7826         do kkk=1,5
7827           do lll=1,3
7828             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7829      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7830 cd            derx(lll,kkk,iii)=0.0d0
7831           enddo
7832         enddo
7833       enddo
7834 cd      gcorr_loc(l-1)=0.0d0
7835 cd      gcorr_loc(j-1)=0.0d0
7836 cd      gcorr_loc(k-1)=0.0d0
7837 cd      eel4=1.0d0
7838 cd      write (iout,*)'Contacts have occurred for peptide groups',
7839 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7840 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7841       if (j.lt.nres-1) then
7842         j1=j+1
7843         j2=j-1
7844       else
7845         j1=j-1
7846         j2=j-2
7847       endif
7848       if (l.lt.nres-1) then
7849         l1=l+1
7850         l2=l-1
7851       else
7852         l1=l-1
7853         l2=l-2
7854       endif
7855       do ll=1,3
7856 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7857 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7858         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7859         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7860 cgrad        ghalf=0.5d0*ggg1(ll)
7861         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7862         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7863         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7864         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7865         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7866         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7867 cgrad        ghalf=0.5d0*ggg2(ll)
7868         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7869         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7870         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7871         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7872         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7873         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7874       enddo
7875 cgrad      do m=i+1,j-1
7876 cgrad        do ll=1,3
7877 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7878 cgrad        enddo
7879 cgrad      enddo
7880 cgrad      do m=k+1,l-1
7881 cgrad        do ll=1,3
7882 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7883 cgrad        enddo
7884 cgrad      enddo
7885 cgrad      do m=i+2,j2
7886 cgrad        do ll=1,3
7887 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7888 cgrad        enddo
7889 cgrad      enddo
7890 cgrad      do m=k+2,l2
7891 cgrad        do ll=1,3
7892 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7893 cgrad        enddo
7894 cgrad      enddo
7895 cd      do iii=1,nres-3
7896 cd        write (2,*) iii,gcorr_loc(iii)
7897 cd      enddo
7898       endif ! calc_grad
7899       eello4=ekont*eel4
7900 cd      write (2,*) 'ekont',ekont
7901 cd      write (iout,*) 'eello4',ekont*eel4
7902       return
7903       end
7904 C---------------------------------------------------------------------------
7905       double precision function eello5(i,j,k,l,jj,kk)
7906       implicit real*8 (a-h,o-z)
7907       include 'DIMENSIONS'
7908       include 'DIMENSIONS.ZSCOPT'
7909       include 'COMMON.IOUNITS'
7910       include 'COMMON.CHAIN'
7911       include 'COMMON.DERIV'
7912       include 'COMMON.INTERACT'
7913       include 'COMMON.CONTACTS'
7914       include 'COMMON.CONTMAT'
7915       include 'COMMON.CORRMAT'
7916       include 'COMMON.TORSION'
7917       include 'COMMON.VAR'
7918       include 'COMMON.GEO'
7919       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7920       double precision ggg1(3),ggg2(3)
7921 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7922 C                                                                              C
7923 C                            Parallel chains                                   C
7924 C                                                                              C
7925 C          o             o                   o             o                   C
7926 C         /l\           / \             \   / \           / \   /              C
7927 C        /   \         /   \             \ /   \         /   \ /               C
7928 C       j| o |l1       | o |              o| o |         | o |o                C
7929 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7930 C      \i/   \         /   \ /             /   \         /   \                 C
7931 C       o    k1             o                                                  C
7932 C         (I)          (II)                (III)          (IV)                 C
7933 C                                                                              C
7934 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7935 C                                                                              C
7936 C                            Antiparallel chains                               C
7937 C                                                                              C
7938 C          o             o                   o             o                   C
7939 C         /j\           / \             \   / \           / \   /              C
7940 C        /   \         /   \             \ /   \         /   \ /               C
7941 C      j1| o |l        | o |              o| o |         | o |o                C
7942 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7943 C      \i/   \         /   \ /             /   \         /   \                 C
7944 C       o     k1            o                                                  C
7945 C         (I)          (II)                (III)          (IV)                 C
7946 C                                                                              C
7947 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7948 C                                                                              C
7949 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7950 C                                                                              C
7951 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7952 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7953 cd        eello5=0.0d0
7954 cd        return
7955 cd      endif
7956 cd      write (iout,*)
7957 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7958 cd     &   ' and',k,l
7959       itk=itype2loc(itype(k))
7960       itl=itype2loc(itype(l))
7961       itj=itype2loc(itype(j))
7962       eello5_1=0.0d0
7963       eello5_2=0.0d0
7964       eello5_3=0.0d0
7965       eello5_4=0.0d0
7966 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7967 cd     &   eel5_3_num,eel5_4_num)
7968       do iii=1,2
7969         do kkk=1,5
7970           do lll=1,3
7971             derx(lll,kkk,iii)=0.0d0
7972           enddo
7973         enddo
7974       enddo
7975 cd      eij=facont_hb(jj,i)
7976 cd      ekl=facont_hb(kk,k)
7977 cd      ekont=eij*ekl
7978 cd      write (iout,*)'Contacts have occurred for peptide groups',
7979 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7980 cd      goto 1111
7981 C Contribution from the graph I.
7982 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7983 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7984       call transpose2(EUg(1,1,k),auxmat(1,1))
7985       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7986       vv(1)=pizda(1,1)-pizda(2,2)
7987       vv(2)=pizda(1,2)+pizda(2,1)
7988       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7989      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7990       if (calc_grad) then
7991 C Explicit gradient in virtual-dihedral angles.
7992       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7993      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7994      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7995       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7996       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7997       vv(1)=pizda(1,1)-pizda(2,2)
7998       vv(2)=pizda(1,2)+pizda(2,1)
7999       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8000      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8001      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8002       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8003       vv(1)=pizda(1,1)-pizda(2,2)
8004       vv(2)=pizda(1,2)+pizda(2,1)
8005       if (l.eq.j+1) then
8006         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8007      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8008      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8009       else
8010         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8011      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8012      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8013       endif
8014 C Cartesian gradient
8015       do iii=1,2
8016         do kkk=1,5
8017           do lll=1,3
8018             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8019      &        pizda(1,1))
8020             vv(1)=pizda(1,1)-pizda(2,2)
8021             vv(2)=pizda(1,2)+pizda(2,1)
8022             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8023      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8024      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8025           enddo
8026         enddo
8027       enddo
8028       endif ! calc_grad
8029 c      goto 1112
8030 c1111  continue
8031 C Contribution from graph II
8032       call transpose2(EE(1,1,k),auxmat(1,1))
8033       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8034       vv(1)=pizda(1,1)+pizda(2,2)
8035       vv(2)=pizda(2,1)-pizda(1,2)
8036       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8037      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8038       if (calc_grad) then
8039 C Explicit gradient in virtual-dihedral angles.
8040       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8041      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8042       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8043       vv(1)=pizda(1,1)+pizda(2,2)
8044       vv(2)=pizda(2,1)-pizda(1,2)
8045       if (l.eq.j+1) then
8046         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8047      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8048      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8049       else
8050         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8051      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8052      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8053       endif
8054 C Cartesian gradient
8055       do iii=1,2
8056         do kkk=1,5
8057           do lll=1,3
8058             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8059      &        pizda(1,1))
8060             vv(1)=pizda(1,1)+pizda(2,2)
8061             vv(2)=pizda(2,1)-pizda(1,2)
8062             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8063      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8064      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8065           enddo
8066         enddo
8067       enddo
8068       endif ! calc_grad
8069 cd      goto 1112
8070 cd1111  continue
8071       if (l.eq.j+1) then
8072 cd        goto 1110
8073 C Parallel orientation
8074 C Contribution from graph III
8075         call transpose2(EUg(1,1,l),auxmat(1,1))
8076         call matmat2(AEA(1,1,2),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         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8080      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8081         if (calc_grad) then
8082 C Explicit gradient in virtual-dihedral angles.
8083         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8084      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8085      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8086         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8087         vv(1)=pizda(1,1)-pizda(2,2)
8088         vv(2)=pizda(1,2)+pizda(2,1)
8089         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8090      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8091      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8092         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8093         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8094         vv(1)=pizda(1,1)-pizda(2,2)
8095         vv(2)=pizda(1,2)+pizda(2,1)
8096         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8097      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8098      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8099 C Cartesian gradient
8100         do iii=1,2
8101           do kkk=1,5
8102             do lll=1,3
8103               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8104      &          pizda(1,1))
8105               vv(1)=pizda(1,1)-pizda(2,2)
8106               vv(2)=pizda(1,2)+pizda(2,1)
8107               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8108      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8109      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8110             enddo
8111           enddo
8112         enddo
8113 cd        goto 1112
8114 C Contribution from graph IV
8115 cd1110    continue
8116         call transpose2(EE(1,1,l),auxmat(1,1))
8117         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8118         vv(1)=pizda(1,1)+pizda(2,2)
8119         vv(2)=pizda(2,1)-pizda(1,2)
8120         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8121      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8122 C Explicit gradient in virtual-dihedral angles.
8123         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8124      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8125         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8126         vv(1)=pizda(1,1)+pizda(2,2)
8127         vv(2)=pizda(2,1)-pizda(1,2)
8128         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8129      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8130      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8131 C Cartesian gradient
8132         do iii=1,2
8133           do kkk=1,5
8134             do lll=1,3
8135               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8136      &          pizda(1,1))
8137               vv(1)=pizda(1,1)+pizda(2,2)
8138               vv(2)=pizda(2,1)-pizda(1,2)
8139               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8140      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8141      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8142             enddo
8143           enddo
8144         enddo
8145         endif ! calc_grad
8146       else
8147 C Antiparallel orientation
8148 C Contribution from graph III
8149 c        goto 1110
8150         call transpose2(EUg(1,1,j),auxmat(1,1))
8151         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8152         vv(1)=pizda(1,1)-pizda(2,2)
8153         vv(2)=pizda(1,2)+pizda(2,1)
8154         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8155      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8156         if (calc_grad) then
8157 C Explicit gradient in virtual-dihedral angles.
8158         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8159      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8160      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8161         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8162         vv(1)=pizda(1,1)-pizda(2,2)
8163         vv(2)=pizda(1,2)+pizda(2,1)
8164         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8165      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8166      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8167         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8168         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8169         vv(1)=pizda(1,1)-pizda(2,2)
8170         vv(2)=pizda(1,2)+pizda(2,1)
8171         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8172      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8173      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8174 C Cartesian gradient
8175         do iii=1,2
8176           do kkk=1,5
8177             do lll=1,3
8178               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8179      &          pizda(1,1))
8180               vv(1)=pizda(1,1)-pizda(2,2)
8181               vv(2)=pizda(1,2)+pizda(2,1)
8182               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8183      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8184      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8185             enddo
8186           enddo
8187         enddo
8188         endif ! calc_grad
8189 cd        goto 1112
8190 C Contribution from graph IV
8191 1110    continue
8192         call transpose2(EE(1,1,j),auxmat(1,1))
8193         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8194         vv(1)=pizda(1,1)+pizda(2,2)
8195         vv(2)=pizda(2,1)-pizda(1,2)
8196         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8197      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8198         if (calc_grad) then
8199 C Explicit gradient in virtual-dihedral angles.
8200         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8201      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8202         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8203         vv(1)=pizda(1,1)+pizda(2,2)
8204         vv(2)=pizda(2,1)-pizda(1,2)
8205         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8206      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8207      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8208 C Cartesian gradient
8209         do iii=1,2
8210           do kkk=1,5
8211             do lll=1,3
8212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8213      &          pizda(1,1))
8214               vv(1)=pizda(1,1)+pizda(2,2)
8215               vv(2)=pizda(2,1)-pizda(1,2)
8216               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8217      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8218      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8219             enddo
8220           enddo
8221         enddo
8222         endif ! calc_grad
8223       endif
8224 1112  continue
8225       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8226 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8227 cd        write (2,*) 'ijkl',i,j,k,l
8228 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8229 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8230 cd      endif
8231 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8232 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8233 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8234 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8235       if (calc_grad) then
8236       if (j.lt.nres-1) then
8237         j1=j+1
8238         j2=j-1
8239       else
8240         j1=j-1
8241         j2=j-2
8242       endif
8243       if (l.lt.nres-1) then
8244         l1=l+1
8245         l2=l-1
8246       else
8247         l1=l-1
8248         l2=l-2
8249       endif
8250 cd      eij=1.0d0
8251 cd      ekl=1.0d0
8252 cd      ekont=1.0d0
8253 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8254 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8255 C        summed up outside the subrouine as for the other subroutines
8256 C        handling long-range interactions. The old code is commented out
8257 C        with "cgrad" to keep track of changes.
8258       do ll=1,3
8259 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8260 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8261         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8262         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8263 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8264 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8265 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8266 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8267 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8268 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8269 c     &   gradcorr5ij,
8270 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8271 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8272 cgrad        ghalf=0.5d0*ggg1(ll)
8273 cd        ghalf=0.0d0
8274         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8275         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8276         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8277         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8278         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8279         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8280 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8281 cgrad        ghalf=0.5d0*ggg2(ll)
8282 cd        ghalf=0.0d0
8283         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8284         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8285         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8286         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8287         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8288         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8289       enddo
8290       endif ! calc_grad
8291 cd      goto 1112
8292 cgrad      do m=i+1,j-1
8293 cgrad        do ll=1,3
8294 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8295 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8296 cgrad        enddo
8297 cgrad      enddo
8298 cgrad      do m=k+1,l-1
8299 cgrad        do ll=1,3
8300 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8301 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8302 cgrad        enddo
8303 cgrad      enddo
8304 c1112  continue
8305 cgrad      do m=i+2,j2
8306 cgrad        do ll=1,3
8307 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8308 cgrad        enddo
8309 cgrad      enddo
8310 cgrad      do m=k+2,l2
8311 cgrad        do ll=1,3
8312 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8313 cgrad        enddo
8314 cgrad      enddo
8315 cd      do iii=1,nres-3
8316 cd        write (2,*) iii,g_corr5_loc(iii)
8317 cd      enddo
8318       eello5=ekont*eel5
8319 cd      write (2,*) 'ekont',ekont
8320 cd      write (iout,*) 'eello5',ekont*eel5
8321       return
8322       end
8323 c--------------------------------------------------------------------------
8324       double precision function eello6(i,j,k,l,jj,kk)
8325       implicit real*8 (a-h,o-z)
8326       include 'DIMENSIONS'
8327       include 'DIMENSIONS.ZSCOPT'
8328       include 'COMMON.IOUNITS'
8329       include 'COMMON.CHAIN'
8330       include 'COMMON.DERIV'
8331       include 'COMMON.INTERACT'
8332       include 'COMMON.CONTACTS'
8333       include 'COMMON.CONTMAT'
8334       include 'COMMON.CORRMAT'
8335       include 'COMMON.TORSION'
8336       include 'COMMON.VAR'
8337       include 'COMMON.GEO'
8338       include 'COMMON.FFIELD'
8339       double precision ggg1(3),ggg2(3)
8340 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8341 cd        eello6=0.0d0
8342 cd        return
8343 cd      endif
8344 cd      write (iout,*)
8345 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8346 cd     &   ' and',k,l
8347       eello6_1=0.0d0
8348       eello6_2=0.0d0
8349       eello6_3=0.0d0
8350       eello6_4=0.0d0
8351       eello6_5=0.0d0
8352       eello6_6=0.0d0
8353 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8354 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8355       do iii=1,2
8356         do kkk=1,5
8357           do lll=1,3
8358             derx(lll,kkk,iii)=0.0d0
8359           enddo
8360         enddo
8361       enddo
8362 cd      eij=facont_hb(jj,i)
8363 cd      ekl=facont_hb(kk,k)
8364 cd      ekont=eij*ekl
8365 cd      eij=1.0d0
8366 cd      ekl=1.0d0
8367 cd      ekont=1.0d0
8368       if (l.eq.j+1) then
8369         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8370         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8371         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8372         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8373         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8374         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8375       else
8376         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8377         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8378         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8379         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8380         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8381           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8382         else
8383           eello6_5=0.0d0
8384         endif
8385         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8386       endif
8387 C If turn contributions are considered, they will be handled separately.
8388       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8389 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8390 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8391 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8392 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8393 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8394 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8395 cd      goto 1112
8396       if (calc_grad) then
8397       if (j.lt.nres-1) then
8398         j1=j+1
8399         j2=j-1
8400       else
8401         j1=j-1
8402         j2=j-2
8403       endif
8404       if (l.lt.nres-1) then
8405         l1=l+1
8406         l2=l-1
8407       else
8408         l1=l-1
8409         l2=l-2
8410       endif
8411       do ll=1,3
8412 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8413 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8414 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8415 cgrad        ghalf=0.5d0*ggg1(ll)
8416 cd        ghalf=0.0d0
8417         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8418         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8419         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8420         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8421         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8422         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8423         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8424         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8425 cgrad        ghalf=0.5d0*ggg2(ll)
8426 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8427 cd        ghalf=0.0d0
8428         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8429         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8430         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8431         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8432         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8433         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8434       enddo
8435       endif ! calc_grad
8436 cd      goto 1112
8437 cgrad      do m=i+1,j-1
8438 cgrad        do ll=1,3
8439 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8440 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8441 cgrad        enddo
8442 cgrad      enddo
8443 cgrad      do m=k+1,l-1
8444 cgrad        do ll=1,3
8445 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8446 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8447 cgrad        enddo
8448 cgrad      enddo
8449 cgrad1112  continue
8450 cgrad      do m=i+2,j2
8451 cgrad        do ll=1,3
8452 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8453 cgrad        enddo
8454 cgrad      enddo
8455 cgrad      do m=k+2,l2
8456 cgrad        do ll=1,3
8457 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8458 cgrad        enddo
8459 cgrad      enddo
8460 cd      do iii=1,nres-3
8461 cd        write (2,*) iii,g_corr6_loc(iii)
8462 cd      enddo
8463       eello6=ekont*eel6
8464 cd      write (2,*) 'ekont',ekont
8465 cd      write (iout,*) 'eello6',ekont*eel6
8466       return
8467       end
8468 c--------------------------------------------------------------------------
8469       double precision function eello6_graph1(i,j,k,l,imat,swap)
8470       implicit real*8 (a-h,o-z)
8471       include 'DIMENSIONS'
8472       include 'DIMENSIONS.ZSCOPT'
8473       include 'COMMON.IOUNITS'
8474       include 'COMMON.CHAIN'
8475       include 'COMMON.DERIV'
8476       include 'COMMON.INTERACT'
8477       include 'COMMON.CONTACTS'
8478       include 'COMMON.CONTMAT'
8479       include 'COMMON.CORRMAT'
8480       include 'COMMON.TORSION'
8481       include 'COMMON.VAR'
8482       include 'COMMON.GEO'
8483       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8484       logical swap
8485       logical lprn
8486       common /kutas/ lprn
8487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8488 C                                                                              C
8489 C      Parallel       Antiparallel                                             C
8490 C                                                                              C
8491 C          o             o                                                     C
8492 C         /l\           /j\                                                    C
8493 C        /   \         /   \                                                   C
8494 C       /| o |         | o |\                                                  C
8495 C     \ j|/k\|  /   \  |/k\|l /                                                C
8496 C      \ /   \ /     \ /   \ /                                                 C
8497 C       o     o       o     o                                                  C
8498 C       i             i                                                        C
8499 C                                                                              C
8500 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8501       itk=itype2loc(itype(k))
8502       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8503       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8504       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8505       call transpose2(EUgC(1,1,k),auxmat(1,1))
8506       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8507       vv1(1)=pizda1(1,1)-pizda1(2,2)
8508       vv1(2)=pizda1(1,2)+pizda1(2,1)
8509       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8510       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8511       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8512       s5=scalar2(vv(1),Dtobr2(1,i))
8513 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8514       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8515       if (calc_grad) then
8516       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8517      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8518      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8519      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8520      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8521      & +scalar2(vv(1),Dtobr2der(1,i)))
8522       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8523       vv1(1)=pizda1(1,1)-pizda1(2,2)
8524       vv1(2)=pizda1(1,2)+pizda1(2,1)
8525       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8526       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8527       if (l.eq.j+1) then
8528         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8529      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8530      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8531      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8532      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8533       else
8534         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8535      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8536      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8537      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8538      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8539       endif
8540       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8541       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8542       vv1(1)=pizda1(1,1)-pizda1(2,2)
8543       vv1(2)=pizda1(1,2)+pizda1(2,1)
8544       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8545      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8546      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8547      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8548       do iii=1,2
8549         if (swap) then
8550           ind=3-iii
8551         else
8552           ind=iii
8553         endif
8554         do kkk=1,5
8555           do lll=1,3
8556             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8557             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8558             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8559             call transpose2(EUgC(1,1,k),auxmat(1,1))
8560             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8561      &        pizda1(1,1))
8562             vv1(1)=pizda1(1,1)-pizda1(2,2)
8563             vv1(2)=pizda1(1,2)+pizda1(2,1)
8564             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8565             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8566      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8567             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8568      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8569             s5=scalar2(vv(1),Dtobr2(1,i))
8570             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8571           enddo
8572         enddo
8573       enddo
8574       endif ! calc_grad
8575       return
8576       end
8577 c----------------------------------------------------------------------------
8578       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8579       implicit real*8 (a-h,o-z)
8580       include 'DIMENSIONS'
8581       include 'DIMENSIONS.ZSCOPT'
8582       include 'COMMON.IOUNITS'
8583       include 'COMMON.CHAIN'
8584       include 'COMMON.DERIV'
8585       include 'COMMON.INTERACT'
8586       include 'COMMON.CONTACTS'
8587       include 'COMMON.CONTMAT'
8588       include 'COMMON.CORRMAT'
8589       include 'COMMON.TORSION'
8590       include 'COMMON.VAR'
8591       include 'COMMON.GEO'
8592       logical swap
8593       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8594      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8595       logical lprn
8596       common /kutas/ lprn
8597 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8598 C                                                                              C
8599 C      Parallel       Antiparallel                                             C
8600 C                                                                              C
8601 C          o             o                                                     C
8602 C     \   /l\           /j\   /                                                C
8603 C      \ /   \         /   \ /                                                 C
8604 C       o| o |         | o |o                                                  C
8605 C     \ j|/k\|      \  |/k\|l                                                  C
8606 C      \ /   \       \ /   \                                                   C
8607 C       o             o                                                        C
8608 C       i             i                                                        C
8609 C                                                                              C
8610 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8611 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8612 C AL 7/4/01 s1 would occur in the sixth-order moment,
8613 C           but not in a cluster cumulant
8614 #ifdef MOMENT
8615       s1=dip(1,jj,i)*dip(1,kk,k)
8616 #endif
8617       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8618       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8619       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8620       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8621       call transpose2(EUg(1,1,k),auxmat(1,1))
8622       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8623       vv(1)=pizda(1,1)-pizda(2,2)
8624       vv(2)=pizda(1,2)+pizda(2,1)
8625       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8626 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8627 #ifdef MOMENT
8628       eello6_graph2=-(s1+s2+s3+s4)
8629 #else
8630       eello6_graph2=-(s2+s3+s4)
8631 #endif
8632 c      eello6_graph2=-s3
8633 C Derivatives in gamma(i-1)
8634       if (calc_grad) then
8635       if (i.gt.1) then
8636 #ifdef MOMENT
8637         s1=dipderg(1,jj,i)*dip(1,kk,k)
8638 #endif
8639         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8640         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8641         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8642         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8643 #ifdef MOMENT
8644         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8647 #endif
8648 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8649       endif
8650 C Derivatives in gamma(k-1)
8651 #ifdef MOMENT
8652       s1=dip(1,jj,i)*dipderg(1,kk,k)
8653 #endif
8654       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8655       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8656       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8657       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8658       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8659       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8660       vv(1)=pizda(1,1)-pizda(2,2)
8661       vv(2)=pizda(1,2)+pizda(2,1)
8662       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8663 #ifdef MOMENT
8664       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8665 #else
8666       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8667 #endif
8668 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8669 C Derivatives in gamma(j-1) or gamma(l-1)
8670       if (j.gt.1) then
8671 #ifdef MOMENT
8672         s1=dipderg(3,jj,i)*dip(1,kk,k)
8673 #endif
8674         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8675         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8676         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8677         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8678         vv(1)=pizda(1,1)-pizda(2,2)
8679         vv(2)=pizda(1,2)+pizda(2,1)
8680         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8681 #ifdef MOMENT
8682         if (swap) then
8683           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8684         else
8685           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8686         endif
8687 #endif
8688         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8689 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8690       endif
8691 C Derivatives in gamma(l-1) or gamma(j-1)
8692       if (l.gt.1) then
8693 #ifdef MOMENT
8694         s1=dip(1,jj,i)*dipderg(3,kk,k)
8695 #endif
8696         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8697         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8698         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8699         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8700         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8701         vv(1)=pizda(1,1)-pizda(2,2)
8702         vv(2)=pizda(1,2)+pizda(2,1)
8703         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8704 #ifdef MOMENT
8705         if (swap) then
8706           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8707         else
8708           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8709         endif
8710 #endif
8711         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8712 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8713       endif
8714 C Cartesian derivatives.
8715       if (lprn) then
8716         write (2,*) 'In eello6_graph2'
8717         do iii=1,2
8718           write (2,*) 'iii=',iii
8719           do kkk=1,5
8720             write (2,*) 'kkk=',kkk
8721             do jjj=1,2
8722               write (2,'(3(2f10.5),5x)')
8723      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8724             enddo
8725           enddo
8726         enddo
8727       endif
8728       do iii=1,2
8729         do kkk=1,5
8730           do lll=1,3
8731 #ifdef MOMENT
8732             if (iii.eq.1) then
8733               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8734             else
8735               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8736             endif
8737 #endif
8738             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8739      &        auxvec(1))
8740             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8741             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8742      &        auxvec(1))
8743             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8744             call transpose2(EUg(1,1,k),auxmat(1,1))
8745             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8746      &        pizda(1,1))
8747             vv(1)=pizda(1,1)-pizda(2,2)
8748             vv(2)=pizda(1,2)+pizda(2,1)
8749             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8750 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8751 #ifdef MOMENT
8752             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8753 #else
8754             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8755 #endif
8756             if (swap) then
8757               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8758             else
8759               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8760             endif
8761           enddo
8762         enddo
8763       enddo
8764       endif ! calc_grad
8765       return
8766       end
8767 c----------------------------------------------------------------------------
8768       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8769       implicit real*8 (a-h,o-z)
8770       include 'DIMENSIONS'
8771       include 'DIMENSIONS.ZSCOPT'
8772       include 'COMMON.IOUNITS'
8773       include 'COMMON.CHAIN'
8774       include 'COMMON.DERIV'
8775       include 'COMMON.INTERACT'
8776       include 'COMMON.CONTACTS'
8777       include 'COMMON.CONTMAT'
8778       include 'COMMON.CORRMAT'
8779       include 'COMMON.TORSION'
8780       include 'COMMON.VAR'
8781       include 'COMMON.GEO'
8782       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8783       logical swap
8784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8785 C                                                                              C
8786 C      Parallel       Antiparallel                                             C
8787 C                                                                              C
8788 C          o             o                                                     C
8789 C         /l\   /   \   /j\                                                    C
8790 C        /   \ /     \ /   \                                                   C
8791 C       /| o |o       o| o |\                                                  C
8792 C       j|/k\|  /      |/k\|l /                                                C
8793 C        /   \ /       /   \ /                                                 C
8794 C       /     o       /     o                                                  C
8795 C       i             i                                                        C
8796 C                                                                              C
8797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8798 C
8799 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8800 C           energy moment and not to the cluster cumulant.
8801       iti=itortyp(itype(i))
8802       if (j.lt.nres-1) then
8803         itj1=itype2loc(itype(j+1))
8804       else
8805         itj1=nloctyp
8806       endif
8807       itk=itype2loc(itype(k))
8808       itk1=itype2loc(itype(k+1))
8809       if (l.lt.nres-1) then
8810         itl1=itype2loc(itype(l+1))
8811       else
8812         itl1=nloctyp
8813       endif
8814 #ifdef MOMENT
8815       s1=dip(4,jj,i)*dip(4,kk,k)
8816 #endif
8817       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8818       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8819       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8820       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8821       call transpose2(EE(1,1,k),auxmat(1,1))
8822       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8823       vv(1)=pizda(1,1)+pizda(2,2)
8824       vv(2)=pizda(2,1)-pizda(1,2)
8825       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8826 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8827 cd     & "sum",-(s2+s3+s4)
8828 #ifdef MOMENT
8829       eello6_graph3=-(s1+s2+s3+s4)
8830 #else
8831       eello6_graph3=-(s2+s3+s4)
8832 #endif
8833 c      eello6_graph3=-s4
8834 C Derivatives in gamma(k-1)
8835       if (calc_grad) then
8836       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8837       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8838       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8839       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8840 C Derivatives in gamma(l-1)
8841       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8842       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8843       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8844       vv(1)=pizda(1,1)+pizda(2,2)
8845       vv(2)=pizda(2,1)-pizda(1,2)
8846       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8847       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8848 C Cartesian derivatives.
8849       do iii=1,2
8850         do kkk=1,5
8851           do lll=1,3
8852 #ifdef MOMENT
8853             if (iii.eq.1) then
8854               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8855             else
8856               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8857             endif
8858 #endif
8859             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8860      &        auxvec(1))
8861             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8862             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8863      &        auxvec(1))
8864             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8865             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8866      &        pizda(1,1))
8867             vv(1)=pizda(1,1)+pizda(2,2)
8868             vv(2)=pizda(2,1)-pizda(1,2)
8869             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8870 #ifdef MOMENT
8871             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8872 #else
8873             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8874 #endif
8875             if (swap) then
8876               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8877             else
8878               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8879             endif
8880 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8881           enddo
8882         enddo
8883       enddo
8884       endif ! calc_grad
8885       return
8886       end
8887 c----------------------------------------------------------------------------
8888       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8889       implicit real*8 (a-h,o-z)
8890       include 'DIMENSIONS'
8891       include 'DIMENSIONS.ZSCOPT'
8892       include 'COMMON.IOUNITS'
8893       include 'COMMON.CHAIN'
8894       include 'COMMON.DERIV'
8895       include 'COMMON.INTERACT'
8896       include 'COMMON.CONTACTS'
8897       include 'COMMON.CONTMAT'
8898       include 'COMMON.CORRMAT'
8899       include 'COMMON.TORSION'
8900       include 'COMMON.VAR'
8901       include 'COMMON.GEO'
8902       include 'COMMON.FFIELD'
8903       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8904      & auxvec1(2),auxmat1(2,2)
8905       logical swap
8906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8907 C                                                                              C
8908 C      Parallel       Antiparallel                                             C
8909 C                                                                              C
8910 C          o             o                                                     C
8911 C         /l\   /   \   /j\                                                    C
8912 C        /   \ /     \ /   \                                                   C
8913 C       /| o |o       o| o |\                                                  C
8914 C     \ j|/k\|      \  |/k\|l                                                  C
8915 C      \ /   \       \ /   \                                                   C
8916 C       o     \       o     \                                                  C
8917 C       i             i                                                        C
8918 C                                                                              C
8919 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8920 C
8921 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8922 C           energy moment and not to the cluster cumulant.
8923 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8924       iti=itype2loc(itype(i))
8925       itj=itype2loc(itype(j))
8926       if (j.lt.nres-1) then
8927         itj1=itype2loc(itype(j+1))
8928       else
8929         itj1=nloctyp
8930       endif
8931       itk=itype2loc(itype(k))
8932       if (k.lt.nres-1) then
8933         itk1=itype2loc(itype(k+1))
8934       else
8935         itk1=nloctyp
8936       endif
8937       itl=itype2loc(itype(l))
8938       if (l.lt.nres-1) then
8939         itl1=itype2loc(itype(l+1))
8940       else
8941         itl1=nloctyp
8942       endif
8943 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8944 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8945 cd     & ' itl',itl,' itl1',itl1
8946 #ifdef MOMENT
8947       if (imat.eq.1) then
8948         s1=dip(3,jj,i)*dip(3,kk,k)
8949       else
8950         s1=dip(2,jj,j)*dip(2,kk,l)
8951       endif
8952 #endif
8953       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8954       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8955       if (j.eq.l+1) then
8956         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8957         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8958       else
8959         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8960         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8961       endif
8962       call transpose2(EUg(1,1,k),auxmat(1,1))
8963       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8964       vv(1)=pizda(1,1)-pizda(2,2)
8965       vv(2)=pizda(2,1)+pizda(1,2)
8966       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8967 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8968 #ifdef MOMENT
8969       eello6_graph4=-(s1+s2+s3+s4)
8970 #else
8971       eello6_graph4=-(s2+s3+s4)
8972 #endif
8973 C Derivatives in gamma(i-1)
8974       if (calc_grad) then
8975       if (i.gt.1) then
8976 #ifdef MOMENT
8977         if (imat.eq.1) then
8978           s1=dipderg(2,jj,i)*dip(3,kk,k)
8979         else
8980           s1=dipderg(4,jj,j)*dip(2,kk,l)
8981         endif
8982 #endif
8983         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8984         if (j.eq.l+1) then
8985           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8986           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8987         else
8988           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8989           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8990         endif
8991         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8992         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8993 cd          write (2,*) 'turn6 derivatives'
8994 #ifdef MOMENT
8995           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8996 #else
8997           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8998 #endif
8999         else
9000 #ifdef MOMENT
9001           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9002 #else
9003           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9004 #endif
9005         endif
9006       endif
9007 C Derivatives in gamma(k-1)
9008 #ifdef MOMENT
9009       if (imat.eq.1) then
9010         s1=dip(3,jj,i)*dipderg(2,kk,k)
9011       else
9012         s1=dip(2,jj,j)*dipderg(4,kk,l)
9013       endif
9014 #endif
9015       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9016       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9017       if (j.eq.l+1) then
9018         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9019         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9020       else
9021         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9022         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9023       endif
9024       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9025       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9026       vv(1)=pizda(1,1)-pizda(2,2)
9027       vv(2)=pizda(2,1)+pizda(1,2)
9028       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9029       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9030 #ifdef MOMENT
9031         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9032 #else
9033         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9034 #endif
9035       else
9036 #ifdef MOMENT
9037         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9038 #else
9039         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9040 #endif
9041       endif
9042 C Derivatives in gamma(j-1) or gamma(l-1)
9043       if (l.eq.j+1 .and. l.gt.1) then
9044         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9045         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9046         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9047         vv(1)=pizda(1,1)-pizda(2,2)
9048         vv(2)=pizda(2,1)+pizda(1,2)
9049         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9050         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9051       else if (j.gt.1) then
9052         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9053         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9054         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9055         vv(1)=pizda(1,1)-pizda(2,2)
9056         vv(2)=pizda(2,1)+pizda(1,2)
9057         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9058         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9059           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9060         else
9061           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9062         endif
9063       endif
9064 C Cartesian derivatives.
9065       do iii=1,2
9066         do kkk=1,5
9067           do lll=1,3
9068 #ifdef MOMENT
9069             if (iii.eq.1) then
9070               if (imat.eq.1) then
9071                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9072               else
9073                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9074               endif
9075             else
9076               if (imat.eq.1) then
9077                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9078               else
9079                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9080               endif
9081             endif
9082 #endif
9083             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9084      &        auxvec(1))
9085             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9086             if (j.eq.l+1) then
9087               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9088      &          b1(1,j+1),auxvec(1))
9089               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9090             else
9091               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9092      &          b1(1,l+1),auxvec(1))
9093               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9094             endif
9095             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9096      &        pizda(1,1))
9097             vv(1)=pizda(1,1)-pizda(2,2)
9098             vv(2)=pizda(2,1)+pizda(1,2)
9099             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9100             if (swap) then
9101               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9102 #ifdef MOMENT
9103                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9104      &             -(s1+s2+s4)
9105 #else
9106                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9107      &             -(s2+s4)
9108 #endif
9109                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9110               else
9111 #ifdef MOMENT
9112                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9113 #else
9114                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9115 #endif
9116                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9117               endif
9118             else
9119 #ifdef MOMENT
9120               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9121 #else
9122               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9123 #endif
9124               if (l.eq.j+1) then
9125                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9126               else
9127                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9128               endif
9129             endif
9130           enddo
9131         enddo
9132       enddo
9133       endif ! calc_grad
9134       return
9135       end
9136 c----------------------------------------------------------------------------
9137       double precision function eello_turn6(i,jj,kk)
9138       implicit real*8 (a-h,o-z)
9139       include 'DIMENSIONS'
9140       include 'DIMENSIONS.ZSCOPT'
9141       include 'COMMON.IOUNITS'
9142       include 'COMMON.CHAIN'
9143       include 'COMMON.DERIV'
9144       include 'COMMON.INTERACT'
9145       include 'COMMON.CONTACTS'
9146       include 'COMMON.CONTMAT'
9147       include 'COMMON.CORRMAT'
9148       include 'COMMON.TORSION'
9149       include 'COMMON.VAR'
9150       include 'COMMON.GEO'
9151       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9152      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9153      &  ggg1(3),ggg2(3)
9154       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9155      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9156 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9157 C           the respective energy moment and not to the cluster cumulant.
9158       s1=0.0d0
9159       s8=0.0d0
9160       s13=0.0d0
9161 c
9162       eello_turn6=0.0d0
9163       j=i+4
9164       k=i+1
9165       l=i+3
9166       iti=itype2loc(itype(i))
9167       itk=itype2loc(itype(k))
9168       itk1=itype2loc(itype(k+1))
9169       itl=itype2loc(itype(l))
9170       itj=itype2loc(itype(j))
9171 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9172 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9173 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9174 cd        eello6=0.0d0
9175 cd        return
9176 cd      endif
9177 cd      write (iout,*)
9178 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9179 cd     &   ' and',k,l
9180 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9181       do iii=1,2
9182         do kkk=1,5
9183           do lll=1,3
9184             derx_turn(lll,kkk,iii)=0.0d0
9185           enddo
9186         enddo
9187       enddo
9188 cd      eij=1.0d0
9189 cd      ekl=1.0d0
9190 cd      ekont=1.0d0
9191       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9192 cd      eello6_5=0.0d0
9193 cd      write (2,*) 'eello6_5',eello6_5
9194 #ifdef MOMENT
9195       call transpose2(AEA(1,1,1),auxmat(1,1))
9196       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9197       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9198       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9199 #endif
9200       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9201       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9202       s2 = scalar2(b1(1,k),vtemp1(1))
9203 #ifdef MOMENT
9204       call transpose2(AEA(1,1,2),atemp(1,1))
9205       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9206       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9207       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9208 #endif
9209       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9210       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9211       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9212 #ifdef MOMENT
9213       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9214       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9215       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9216       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9217       ss13 = scalar2(b1(1,k),vtemp4(1))
9218       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9219 #endif
9220 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9221 c      s1=0.0d0
9222 c      s2=0.0d0
9223 c      s8=0.0d0
9224 c      s12=0.0d0
9225 c      s13=0.0d0
9226       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9227 C Derivatives in gamma(i+2)
9228       if (calc_grad) then
9229       s1d =0.0d0
9230       s8d =0.0d0
9231 #ifdef MOMENT
9232       call transpose2(AEA(1,1,1),auxmatd(1,1))
9233       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9234       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9235       call transpose2(AEAderg(1,1,2),atempd(1,1))
9236       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9237       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9238 #endif
9239       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9240       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9241       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9242 c      s1d=0.0d0
9243 c      s2d=0.0d0
9244 c      s8d=0.0d0
9245 c      s12d=0.0d0
9246 c      s13d=0.0d0
9247       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9248 C Derivatives in gamma(i+3)
9249 #ifdef MOMENT
9250       call transpose2(AEA(1,1,1),auxmatd(1,1))
9251       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9252       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9253       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9254 #endif
9255       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9256       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9257       s2d = scalar2(b1(1,k),vtemp1d(1))
9258 #ifdef MOMENT
9259       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9260       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9261 #endif
9262       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9263 #ifdef MOMENT
9264       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9265       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9266       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9267 #endif
9268 c      s1d=0.0d0
9269 c      s2d=0.0d0
9270 c      s8d=0.0d0
9271 c      s12d=0.0d0
9272 c      s13d=0.0d0
9273 #ifdef MOMENT
9274       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9275      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9276 #else
9277       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9278      &               -0.5d0*ekont*(s2d+s12d)
9279 #endif
9280 C Derivatives in gamma(i+4)
9281       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9282       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9283       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9284 #ifdef MOMENT
9285       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9286       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9287       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9288 #endif
9289 c      s1d=0.0d0
9290 c      s2d=0.0d0
9291 c      s8d=0.0d0
9292 C      s12d=0.0d0
9293 c      s13d=0.0d0
9294 #ifdef MOMENT
9295       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9296 #else
9297       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9298 #endif
9299 C Derivatives in gamma(i+5)
9300 #ifdef MOMENT
9301       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9302       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9303       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9304 #endif
9305       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9306       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9307       s2d = scalar2(b1(1,k),vtemp1d(1))
9308 #ifdef MOMENT
9309       call transpose2(AEA(1,1,2),atempd(1,1))
9310       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9311       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9312 #endif
9313       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9314       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9315 #ifdef MOMENT
9316       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9317       ss13d = scalar2(b1(1,k),vtemp4d(1))
9318       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9319 #endif
9320 c      s1d=0.0d0
9321 c      s2d=0.0d0
9322 c      s8d=0.0d0
9323 c      s12d=0.0d0
9324 c      s13d=0.0d0
9325 #ifdef MOMENT
9326       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9327      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9328 #else
9329       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9330      &               -0.5d0*ekont*(s2d+s12d)
9331 #endif
9332 C Cartesian derivatives
9333       do iii=1,2
9334         do kkk=1,5
9335           do lll=1,3
9336 #ifdef MOMENT
9337             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9338             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9339             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9340 #endif
9341             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9342             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9343      &          vtemp1d(1))
9344             s2d = scalar2(b1(1,k),vtemp1d(1))
9345 #ifdef MOMENT
9346             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9347             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9348             s8d = -(atempd(1,1)+atempd(2,2))*
9349      &           scalar2(cc(1,1,l),vtemp2(1))
9350 #endif
9351             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9352      &           auxmatd(1,1))
9353             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9354             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9355 c      s1d=0.0d0
9356 c      s2d=0.0d0
9357 c      s8d=0.0d0
9358 c      s12d=0.0d0
9359 c      s13d=0.0d0
9360 #ifdef MOMENT
9361             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9362      &        - 0.5d0*(s1d+s2d)
9363 #else
9364             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9365      &        - 0.5d0*s2d
9366 #endif
9367 #ifdef MOMENT
9368             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9369      &        - 0.5d0*(s8d+s12d)
9370 #else
9371             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9372      &        - 0.5d0*s12d
9373 #endif
9374           enddo
9375         enddo
9376       enddo
9377 #ifdef MOMENT
9378       do kkk=1,5
9379         do lll=1,3
9380           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9381      &      achuj_tempd(1,1))
9382           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9383           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9384           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9385           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9386           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9387      &      vtemp4d(1))
9388           ss13d = scalar2(b1(1,k),vtemp4d(1))
9389           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9390           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9391         enddo
9392       enddo
9393 #endif
9394 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9395 cd     &  16*eel_turn6_num
9396 cd      goto 1112
9397       if (j.lt.nres-1) then
9398         j1=j+1
9399         j2=j-1
9400       else
9401         j1=j-1
9402         j2=j-2
9403       endif
9404       if (l.lt.nres-1) then
9405         l1=l+1
9406         l2=l-1
9407       else
9408         l1=l-1
9409         l2=l-2
9410       endif
9411       do ll=1,3
9412 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9413 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9414 cgrad        ghalf=0.5d0*ggg1(ll)
9415 cd        ghalf=0.0d0
9416         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9417         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9418         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9419      &    +ekont*derx_turn(ll,2,1)
9420         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9421         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9422      &    +ekont*derx_turn(ll,4,1)
9423         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9424         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9425         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9426 cgrad        ghalf=0.5d0*ggg2(ll)
9427 cd        ghalf=0.0d0
9428         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9429      &    +ekont*derx_turn(ll,2,2)
9430         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9431         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9432      &    +ekont*derx_turn(ll,4,2)
9433         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9434         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9435         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9436       enddo
9437 cd      goto 1112
9438 cgrad      do m=i+1,j-1
9439 cgrad        do ll=1,3
9440 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9441 cgrad        enddo
9442 cgrad      enddo
9443 cgrad      do m=k+1,l-1
9444 cgrad        do ll=1,3
9445 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9446 cgrad        enddo
9447 cgrad      enddo
9448 cgrad1112  continue
9449 cgrad      do m=i+2,j2
9450 cgrad        do ll=1,3
9451 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9452 cgrad        enddo
9453 cgrad      enddo
9454 cgrad      do m=k+2,l2
9455 cgrad        do ll=1,3
9456 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9457 cgrad        enddo
9458 cgrad      enddo
9459 cd      do iii=1,nres-3
9460 cd        write (2,*) iii,g_corr6_loc(iii)
9461 cd      enddo
9462       endif ! calc_grad
9463       eello_turn6=ekont*eel_turn6
9464 cd      write (2,*) 'ekont',ekont
9465 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9466       return
9467       end
9468 #endif
9469 crc-------------------------------------------------
9470 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9471       subroutine Eliptransfer(eliptran)
9472       implicit real*8 (a-h,o-z)
9473       include 'DIMENSIONS'
9474       include 'DIMENSIONS.ZSCOPT'
9475       include 'COMMON.GEO'
9476       include 'COMMON.VAR'
9477       include 'COMMON.LOCAL'
9478       include 'COMMON.CHAIN'
9479       include 'COMMON.DERIV'
9480       include 'COMMON.INTERACT'
9481       include 'COMMON.IOUNITS'
9482       include 'COMMON.CALC'
9483       include 'COMMON.CONTROL'
9484       include 'COMMON.SPLITELE'
9485       include 'COMMON.SBRIDGE'
9486 C this is done by Adasko
9487 C      print *,"wchodze"
9488 C structure of box:
9489 C      water
9490 C--bordliptop-- buffore starts
9491 C--bufliptop--- here true lipid starts
9492 C      lipid
9493 C--buflipbot--- lipid ends buffore starts
9494 C--bordlipbot--buffore ends
9495       eliptran=0.0
9496       do i=1,nres
9497 C       do i=1,1
9498         if (itype(i).eq.ntyp1) cycle
9499
9500         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9501         if (positi.le.0) positi=positi+boxzsize
9502 C        print *,i
9503 C first for peptide groups
9504 c for each residue check if it is in lipid or lipid water border area
9505        if ((positi.gt.bordlipbot)
9506      &.and.(positi.lt.bordliptop)) then
9507 C the energy transfer exist
9508         if (positi.lt.buflipbot) then
9509 C what fraction I am in
9510          fracinbuf=1.0d0-
9511      &        ((positi-bordlipbot)/lipbufthick)
9512 C lipbufthick is thickenes of lipid buffore
9513          sslip=sscalelip(fracinbuf)
9514          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9515          eliptran=eliptran+sslip*pepliptran
9516          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9517          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9518 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9519         elseif (positi.gt.bufliptop) then
9520          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9521          sslip=sscalelip(fracinbuf)
9522          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9523          eliptran=eliptran+sslip*pepliptran
9524          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9525          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9526 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9527 C          print *, "doing sscalefor top part"
9528 C         print *,i,sslip,fracinbuf,ssgradlip
9529         else
9530          eliptran=eliptran+pepliptran
9531 C         print *,"I am in true lipid"
9532         endif
9533 C       else
9534 C       eliptran=elpitran+0.0 ! I am in water
9535        endif
9536        enddo
9537 C       print *, "nic nie bylo w lipidzie?"
9538 C now multiply all by the peptide group transfer factor
9539 C       eliptran=eliptran*pepliptran
9540 C now the same for side chains
9541 CV       do i=1,1
9542        do i=1,nres
9543         if (itype(i).eq.ntyp1) cycle
9544         positi=(mod(c(3,i+nres),boxzsize))
9545         if (positi.le.0) positi=positi+boxzsize
9546 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9547 c for each residue check if it is in lipid or lipid water border area
9548 C       respos=mod(c(3,i+nres),boxzsize)
9549 C       print *,positi,bordlipbot,buflipbot
9550        if ((positi.gt.bordlipbot)
9551      & .and.(positi.lt.bordliptop)) then
9552 C the energy transfer exist
9553         if (positi.lt.buflipbot) then
9554          fracinbuf=1.0d0-
9555      &     ((positi-bordlipbot)/lipbufthick)
9556 C lipbufthick is thickenes of lipid buffore
9557          sslip=sscalelip(fracinbuf)
9558          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9559          eliptran=eliptran+sslip*liptranene(itype(i))
9560          gliptranx(3,i)=gliptranx(3,i)
9561      &+ssgradlip*liptranene(itype(i))
9562          gliptranc(3,i-1)= gliptranc(3,i-1)
9563      &+ssgradlip*liptranene(itype(i))
9564 C         print *,"doing sccale for lower part"
9565         elseif (positi.gt.bufliptop) then
9566          fracinbuf=1.0d0-
9567      &((bordliptop-positi)/lipbufthick)
9568          sslip=sscalelip(fracinbuf)
9569          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9570          eliptran=eliptran+sslip*liptranene(itype(i))
9571          gliptranx(3,i)=gliptranx(3,i)
9572      &+ssgradlip*liptranene(itype(i))
9573          gliptranc(3,i-1)= gliptranc(3,i-1)
9574      &+ssgradlip*liptranene(itype(i))
9575 C          print *, "doing sscalefor top part",sslip,fracinbuf
9576         else
9577          eliptran=eliptran+liptranene(itype(i))
9578 C         print *,"I am in true lipid"
9579         endif
9580         endif ! if in lipid or buffor
9581 C       else
9582 C       eliptran=elpitran+0.0 ! I am in water
9583        enddo
9584        return
9585        end
9586
9587
9588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9589
9590       SUBROUTINE MATVEC2(A1,V1,V2)
9591       implicit real*8 (a-h,o-z)
9592       include 'DIMENSIONS'
9593       DIMENSION A1(2,2),V1(2),V2(2)
9594 c      DO 1 I=1,2
9595 c        VI=0.0
9596 c        DO 3 K=1,2
9597 c    3     VI=VI+A1(I,K)*V1(K)
9598 c        Vaux(I)=VI
9599 c    1 CONTINUE
9600
9601       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9602       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9603
9604       v2(1)=vaux1
9605       v2(2)=vaux2
9606       END
9607 C---------------------------------------
9608       SUBROUTINE MATMAT2(A1,A2,A3)
9609       implicit real*8 (a-h,o-z)
9610       include 'DIMENSIONS'
9611       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9612 c      DIMENSION AI3(2,2)
9613 c        DO  J=1,2
9614 c          A3IJ=0.0
9615 c          DO K=1,2
9616 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9617 c          enddo
9618 c          A3(I,J)=A3IJ
9619 c       enddo
9620 c      enddo
9621
9622       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9623       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9624       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9625       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9626
9627       A3(1,1)=AI3_11
9628       A3(2,1)=AI3_21
9629       A3(1,2)=AI3_12
9630       A3(2,2)=AI3_22
9631       END
9632
9633 c-------------------------------------------------------------------------
9634       double precision function scalar2(u,v)
9635       implicit none
9636       double precision u(2),v(2)
9637       double precision sc
9638       integer i
9639       scalar2=u(1)*v(1)+u(2)*v(2)
9640       return
9641       end
9642
9643 C-----------------------------------------------------------------------------
9644
9645       subroutine transpose2(a,at)
9646       implicit none
9647       double precision a(2,2),at(2,2)
9648       at(1,1)=a(1,1)
9649       at(1,2)=a(2,1)
9650       at(2,1)=a(1,2)
9651       at(2,2)=a(2,2)
9652       return
9653       end
9654 c--------------------------------------------------------------------------
9655       subroutine transpose(n,a,at)
9656       implicit none
9657       integer n,i,j
9658       double precision a(n,n),at(n,n)
9659       do i=1,n
9660         do j=1,n
9661           at(j,i)=a(i,j)
9662         enddo
9663       enddo
9664       return
9665       end
9666 C---------------------------------------------------------------------------
9667       subroutine prodmat3(a1,a2,kk,transp,prod)
9668       implicit none
9669       integer i,j
9670       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9671       logical transp
9672 crc      double precision auxmat(2,2),prod_(2,2)
9673
9674       if (transp) then
9675 crc        call transpose2(kk(1,1),auxmat(1,1))
9676 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9677 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9678
9679            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9680      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9681            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9682      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9683            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9684      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9685            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9686      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9687
9688       else
9689 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9690 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9691
9692            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9693      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9694            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9695      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9696            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9697      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9698            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9699      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9700
9701       endif
9702 c      call transpose2(a2(1,1),a2t(1,1))
9703
9704 crc      print *,transp
9705 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9706 crc      print *,((prod(i,j),i=1,2),j=1,2)
9707
9708       return
9709       end
9710 C-----------------------------------------------------------------------------
9711       double precision function scalar(u,v)
9712       implicit none
9713       double precision u(3),v(3)
9714       double precision sc
9715       integer i
9716       sc=0.0d0
9717       do i=1,3
9718         sc=sc+u(i)*v(i)
9719       enddo
9720       scalar=sc
9721       return
9722       end
9723 C-----------------------------------------------------------------------
9724       double precision function sscale(r)
9725       double precision r,gamm
9726       include "COMMON.SPLITELE"
9727       if(r.lt.r_cut-rlamb) then
9728         sscale=1.0d0
9729       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9730         gamm=(r-(r_cut-rlamb))/rlamb
9731         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9732       else
9733         sscale=0d0
9734       endif
9735       return
9736       end
9737 C-----------------------------------------------------------------------
9738 C-----------------------------------------------------------------------
9739       double precision function sscagrad(r)
9740       double precision r,gamm
9741       include "COMMON.SPLITELE"
9742       if(r.lt.r_cut-rlamb) then
9743         sscagrad=0.0d0
9744       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9745         gamm=(r-(r_cut-rlamb))/rlamb
9746         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9747       else
9748         sscagrad=0.0d0
9749       endif
9750       return
9751       end
9752 C-----------------------------------------------------------------------
9753 C-----------------------------------------------------------------------
9754       double precision function sscalelip(r)
9755       double precision r,gamm
9756       include "COMMON.SPLITELE"
9757 C      if(r.lt.r_cut-rlamb) then
9758 C        sscale=1.0d0
9759 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9760 C        gamm=(r-(r_cut-rlamb))/rlamb
9761         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9762 C      else
9763 C        sscale=0d0
9764 C      endif
9765       return
9766       end
9767 C-----------------------------------------------------------------------
9768       double precision function sscagradlip(r)
9769       double precision r,gamm
9770       include "COMMON.SPLITELE"
9771 C     if(r.lt.r_cut-rlamb) then
9772 C        sscagrad=0.0d0
9773 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9774 C        gamm=(r-(r_cut-rlamb))/rlamb
9775         sscagradlip=r*(6*r-6.0d0)
9776 C      else
9777 C        sscagrad=0.0d0
9778 C      endif
9779       return
9780       end
9781
9782 C-----------------------------------------------------------------------
9783        subroutine set_shield_fac
9784       implicit real*8 (a-h,o-z)
9785       include 'DIMENSIONS'
9786       include 'DIMENSIONS.ZSCOPT'
9787       include 'COMMON.CHAIN'
9788       include 'COMMON.DERIV'
9789       include 'COMMON.IOUNITS'
9790       include 'COMMON.SHIELD'
9791       include 'COMMON.INTERACT'
9792 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9793       double precision div77_81/0.974996043d0/,
9794      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9795
9796 C the vector between center of side_chain and peptide group
9797        double precision pep_side(3),long,side_calf(3),
9798      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9799      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9800 C the line belowe needs to be changed for FGPROC>1
9801       do i=1,nres-1
9802       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9803       ishield_list(i)=0
9804 Cif there two consequtive dummy atoms there is no peptide group between them
9805 C the line below has to be changed for FGPROC>1
9806       VolumeTotal=0.0
9807       do k=1,nres
9808        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9809        dist_pep_side=0.0
9810        dist_side_calf=0.0
9811        do j=1,3
9812 C first lets set vector conecting the ithe side-chain with kth side-chain
9813       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9814 C      pep_side(j)=2.0d0
9815 C and vector conecting the side-chain with its proper calfa
9816       side_calf(j)=c(j,k+nres)-c(j,k)
9817 C      side_calf(j)=2.0d0
9818       pept_group(j)=c(j,i)-c(j,i+1)
9819 C lets have their lenght
9820       dist_pep_side=pep_side(j)**2+dist_pep_side
9821       dist_side_calf=dist_side_calf+side_calf(j)**2
9822       dist_pept_group=dist_pept_group+pept_group(j)**2
9823       enddo
9824        dist_pep_side=dsqrt(dist_pep_side)
9825        dist_pept_group=dsqrt(dist_pept_group)
9826        dist_side_calf=dsqrt(dist_side_calf)
9827       do j=1,3
9828         pep_side_norm(j)=pep_side(j)/dist_pep_side
9829         side_calf_norm(j)=dist_side_calf
9830       enddo
9831 C now sscale fraction
9832        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9833 C       print *,buff_shield,"buff"
9834 C now sscale
9835         if (sh_frac_dist.le.0.0) cycle
9836 C If we reach here it means that this side chain reaches the shielding sphere
9837 C Lets add him to the list for gradient
9838         ishield_list(i)=ishield_list(i)+1
9839 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9840 C this list is essential otherwise problem would be O3
9841         shield_list(ishield_list(i),i)=k
9842 C Lets have the sscale value
9843         if (sh_frac_dist.gt.1.0) then
9844          scale_fac_dist=1.0d0
9845          do j=1,3
9846          sh_frac_dist_grad(j)=0.0d0
9847          enddo
9848         else
9849          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9850      &                   *(2.0*sh_frac_dist-3.0d0)
9851          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9852      &                  /dist_pep_side/buff_shield*0.5
9853 C remember for the final gradient multiply sh_frac_dist_grad(j)
9854 C for side_chain by factor -2 !
9855          do j=1,3
9856          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9857 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9858 C     &                    sh_frac_dist_grad(j)
9859          enddo
9860         endif
9861 C        if ((i.eq.3).and.(k.eq.2)) then
9862 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9863 C     & ,"TU"
9864 C        endif
9865
9866 C this is what is now we have the distance scaling now volume...
9867       short=short_r_sidechain(itype(k))
9868       long=long_r_sidechain(itype(k))
9869       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9870 C now costhet_grad
9871 C       costhet=0.0d0
9872        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9873 C       costhet_fac=0.0d0
9874        do j=1,3
9875          costhet_grad(j)=costhet_fac*pep_side(j)
9876        enddo
9877 C remember for the final gradient multiply costhet_grad(j)
9878 C for side_chain by factor -2 !
9879 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9880 C pep_side0pept_group is vector multiplication
9881       pep_side0pept_group=0.0
9882       do j=1,3
9883       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9884       enddo
9885       cosalfa=(pep_side0pept_group/
9886      & (dist_pep_side*dist_side_calf))
9887       fac_alfa_sin=1.0-cosalfa**2
9888       fac_alfa_sin=dsqrt(fac_alfa_sin)
9889       rkprim=fac_alfa_sin*(long-short)+short
9890 C now costhet_grad
9891        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9892        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9893
9894        do j=1,3
9895          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9896      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9897      &*(long-short)/fac_alfa_sin*cosalfa/
9898      &((dist_pep_side*dist_side_calf))*
9899      &((side_calf(j))-cosalfa*
9900      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9901
9902         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9903      &*(long-short)/fac_alfa_sin*cosalfa
9904      &/((dist_pep_side*dist_side_calf))*
9905      &(pep_side(j)-
9906      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9907        enddo
9908
9909       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9910      &                    /VSolvSphere_div
9911      &                    *wshield
9912 C now the gradient...
9913 C grad_shield is gradient of Calfa for peptide groups
9914 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9915 C     &               costhet,cosphi
9916 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9917 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9918       do j=1,3
9919       grad_shield(j,i)=grad_shield(j,i)
9920 C gradient po skalowaniu
9921      &                +(sh_frac_dist_grad(j)
9922 C  gradient po costhet
9923      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9924      &-scale_fac_dist*(cosphi_grad_long(j))
9925      &/(1.0-cosphi) )*div77_81
9926      &*VofOverlap
9927 C grad_shield_side is Cbeta sidechain gradient
9928       grad_shield_side(j,ishield_list(i),i)=
9929      &        (sh_frac_dist_grad(j)*(-2.0d0)
9930      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9931      &       +scale_fac_dist*(cosphi_grad_long(j))
9932      &        *2.0d0/(1.0-cosphi))
9933      &        *div77_81*VofOverlap
9934
9935        grad_shield_loc(j,ishield_list(i),i)=
9936      &   scale_fac_dist*cosphi_grad_loc(j)
9937      &        *2.0d0/(1.0-cosphi)
9938      &        *div77_81*VofOverlap
9939       enddo
9940       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9941       enddo
9942       fac_shield(i)=VolumeTotal*div77_81+div4_81
9943 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9944       enddo
9945       return
9946       end
9947 C--------------------------------------------------------------------------
9948 C first for shielding is setting of function of side-chains
9949        subroutine set_shield_fac2
9950       implicit real*8 (a-h,o-z)
9951       include 'DIMENSIONS'
9952       include 'DIMENSIONS.ZSCOPT'
9953       include 'COMMON.CHAIN'
9954       include 'COMMON.DERIV'
9955       include 'COMMON.IOUNITS'
9956       include 'COMMON.SHIELD'
9957       include 'COMMON.INTERACT'
9958 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9959       double precision div77_81/0.974996043d0/,
9960      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9961
9962 C the vector between center of side_chain and peptide group
9963        double precision pep_side(3),long,side_calf(3),
9964      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9965      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9966 C the line belowe needs to be changed for FGPROC>1
9967       do i=1,nres-1
9968       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9969       ishield_list(i)=0
9970 Cif there two consequtive dummy atoms there is no peptide group between them
9971 C the line below has to be changed for FGPROC>1
9972       VolumeTotal=0.0
9973       do k=1,nres
9974        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9975        dist_pep_side=0.0
9976        dist_side_calf=0.0
9977        do j=1,3
9978 C first lets set vector conecting the ithe side-chain with kth side-chain
9979       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9980 C      pep_side(j)=2.0d0
9981 C and vector conecting the side-chain with its proper calfa
9982       side_calf(j)=c(j,k+nres)-c(j,k)
9983 C      side_calf(j)=2.0d0
9984       pept_group(j)=c(j,i)-c(j,i+1)
9985 C lets have their lenght
9986       dist_pep_side=pep_side(j)**2+dist_pep_side
9987       dist_side_calf=dist_side_calf+side_calf(j)**2
9988       dist_pept_group=dist_pept_group+pept_group(j)**2
9989       enddo
9990        dist_pep_side=dsqrt(dist_pep_side)
9991        dist_pept_group=dsqrt(dist_pept_group)
9992        dist_side_calf=dsqrt(dist_side_calf)
9993       do j=1,3
9994         pep_side_norm(j)=pep_side(j)/dist_pep_side
9995         side_calf_norm(j)=dist_side_calf
9996       enddo
9997 C now sscale fraction
9998        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9999 C       print *,buff_shield,"buff"
10000 C now sscale
10001         if (sh_frac_dist.le.0.0) cycle
10002 C If we reach here it means that this side chain reaches the shielding sphere
10003 C Lets add him to the list for gradient
10004         ishield_list(i)=ishield_list(i)+1
10005 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10006 C this list is essential otherwise problem would be O3
10007         shield_list(ishield_list(i),i)=k
10008 C Lets have the sscale value
10009         if (sh_frac_dist.gt.1.0) then
10010          scale_fac_dist=1.0d0
10011          do j=1,3
10012          sh_frac_dist_grad(j)=0.0d0
10013          enddo
10014         else
10015          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10016      &                   *(2.0d0*sh_frac_dist-3.0d0)
10017          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10018      &                  /dist_pep_side/buff_shield*0.5d0
10019 C remember for the final gradient multiply sh_frac_dist_grad(j)
10020 C for side_chain by factor -2 !
10021          do j=1,3
10022          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10023 C         sh_frac_dist_grad(j)=0.0d0
10024 C         scale_fac_dist=1.0d0
10025 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10026 C     &                    sh_frac_dist_grad(j)
10027          enddo
10028         endif
10029 C this is what is now we have the distance scaling now volume...
10030       short=short_r_sidechain(itype(k))
10031       long=long_r_sidechain(itype(k))
10032       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10033       sinthet=short/dist_pep_side*costhet
10034 C now costhet_grad
10035 C       costhet=0.6d0
10036 C       sinthet=0.8
10037        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10038 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10039 C     &             -short/dist_pep_side**2/costhet)
10040 C       costhet_fac=0.0d0
10041        do j=1,3
10042          costhet_grad(j)=costhet_fac*pep_side(j)
10043        enddo
10044 C remember for the final gradient multiply costhet_grad(j)
10045 C for side_chain by factor -2 !
10046 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10047 C pep_side0pept_group is vector multiplication
10048       pep_side0pept_group=0.0d0
10049       do j=1,3
10050       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10051       enddo
10052       cosalfa=(pep_side0pept_group/
10053      & (dist_pep_side*dist_side_calf))
10054       fac_alfa_sin=1.0d0-cosalfa**2
10055       fac_alfa_sin=dsqrt(fac_alfa_sin)
10056       rkprim=fac_alfa_sin*(long-short)+short
10057 C      rkprim=short
10058
10059 C now costhet_grad
10060        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10061 C       cosphi=0.6
10062        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10063        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10064      &      dist_pep_side**2)
10065 C       sinphi=0.8
10066        do j=1,3
10067          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10068      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10069      &*(long-short)/fac_alfa_sin*cosalfa/
10070      &((dist_pep_side*dist_side_calf))*
10071      &((side_calf(j))-cosalfa*
10072      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10073 C       cosphi_grad_long(j)=0.0d0
10074         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10075      &*(long-short)/fac_alfa_sin*cosalfa
10076      &/((dist_pep_side*dist_side_calf))*
10077      &(pep_side(j)-
10078      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10079 C       cosphi_grad_loc(j)=0.0d0
10080        enddo
10081 C      print *,sinphi,sinthet
10082       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10083      &                    /VSolvSphere_div
10084 C     &                    *wshield
10085 C now the gradient...
10086       do j=1,3
10087       grad_shield(j,i)=grad_shield(j,i)
10088 C gradient po skalowaniu
10089      &                +(sh_frac_dist_grad(j)*VofOverlap
10090 C  gradient po costhet
10091      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10092      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10093      &       sinphi/sinthet*costhet*costhet_grad(j)
10094      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10095      & )*wshield
10096 C grad_shield_side is Cbeta sidechain gradient
10097       grad_shield_side(j,ishield_list(i),i)=
10098      &        (sh_frac_dist_grad(j)*(-2.0d0)
10099      &        *VofOverlap
10100      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10101      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10102      &       sinphi/sinthet*costhet*costhet_grad(j)
10103      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10104      &       )*wshield
10105
10106        grad_shield_loc(j,ishield_list(i),i)=
10107      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10108      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10109      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10110      &        ))
10111      &        *wshield
10112       enddo
10113       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10114       enddo
10115       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10116 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10117 c     &  " wshield",wshield
10118 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10119       enddo
10120       return
10121       end
10122 C--------------------------------------------------------------------------
10123       double precision function tschebyshev(m,n,x,y)
10124       implicit none
10125       include "DIMENSIONS"
10126       integer i,m,n
10127       double precision x(n),y,yy(0:maxvar),aux
10128 c Tschebyshev polynomial. Note that the first term is omitted
10129 c m=0: the constant term is included
10130 c m=1: the constant term is not included
10131       yy(0)=1.0d0
10132       yy(1)=y
10133       do i=2,n
10134         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10135       enddo
10136       aux=0.0d0
10137       do i=m,n
10138         aux=aux+x(i)*yy(i)
10139       enddo
10140       tschebyshev=aux
10141       return
10142       end
10143 C--------------------------------------------------------------------------
10144       double precision function gradtschebyshev(m,n,x,y)
10145       implicit none
10146       include "DIMENSIONS"
10147       integer i,m,n
10148       double precision x(n+1),y,yy(0:maxvar),aux
10149 c Tschebyshev polynomial. Note that the first term is omitted
10150 c m=0: the constant term is included
10151 c m=1: the constant term is not included
10152       yy(0)=1.0d0
10153       yy(1)=2.0d0*y
10154       do i=2,n
10155         yy(i)=2*y*yy(i-1)-yy(i-2)
10156       enddo
10157       aux=0.0d0
10158       do i=m,n
10159         aux=aux+x(i+1)*yy(i)*(i+1)
10160 C        print *, x(i+1),yy(i),i
10161       enddo
10162       gradtschebyshev=aux
10163       return
10164       end
10165 c----------------------------------------------------------------------------
10166       double precision function sscale2(r,r_cut,r0,rlamb)
10167       implicit none
10168       double precision r,gamm,r_cut,r0,rlamb,rr
10169       rr = dabs(r-r0)
10170 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10171 c      write (2,*) "rr",rr
10172       if(rr.lt.r_cut-rlamb) then
10173         sscale2=1.0d0
10174       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10175         gamm=(rr-(r_cut-rlamb))/rlamb
10176         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10177       else
10178         sscale2=0d0
10179       endif
10180       return
10181       end
10182 C-----------------------------------------------------------------------
10183       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10184       implicit none
10185       double precision r,gamm,r_cut,r0,rlamb,rr
10186       rr = dabs(r-r0)
10187       if(rr.lt.r_cut-rlamb) then
10188         sscalgrad2=0.0d0
10189       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10190         gamm=(rr-(r_cut-rlamb))/rlamb
10191         if (r.ge.r0) then
10192           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10193         else
10194           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10195         endif
10196       else
10197         sscalgrad2=0.0d0
10198       endif
10199       return
10200       end
10201 c----------------------------------------------------------------------------
10202       subroutine e_saxs(Esaxs_constr)
10203       implicit none
10204       include 'DIMENSIONS'
10205       include 'DIMENSIONS.ZSCOPT'
10206       include 'DIMENSIONS.FREE'
10207 #ifdef MPI
10208       include "mpif.h"
10209       include "COMMON.SETUP"
10210       integer IERR
10211 #endif
10212       include 'COMMON.SBRIDGE'
10213       include 'COMMON.CHAIN'
10214       include 'COMMON.GEO'
10215       include 'COMMON.LOCAL'
10216       include 'COMMON.INTERACT'
10217       include 'COMMON.VAR'
10218       include 'COMMON.IOUNITS'
10219       include 'COMMON.DERIV'
10220       include 'COMMON.CONTROL'
10221       include 'COMMON.NAMES'
10222       include 'COMMON.FFIELD'
10223       include 'COMMON.LANGEVIN'
10224       include 'COMMON.SAXS'
10225 c
10226       double precision Esaxs_constr
10227       integer i,iint,j,k,l
10228       double precision PgradC(maxSAXS,3,maxres),
10229      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10230 #ifdef MPI
10231       double precision PgradC_(maxSAXS,3,maxres),
10232      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10233 #endif
10234       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10235      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10236      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10237      & auxX,auxX1,CACAgrad,Cnorm
10238       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10239       double precision dist
10240       external dist
10241 c  SAXS restraint penalty function
10242 #ifdef DEBUG
10243       write(iout,*) "------- SAXS penalty function start -------"
10244       write (iout,*) "nsaxs",nsaxs
10245       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10246       write (iout,*) "Psaxs"
10247       do i=1,nsaxs
10248         write (iout,'(i5,e15.5)') i, Psaxs(i)
10249       enddo
10250 #endif
10251       Esaxs_constr = 0.0d0
10252       do k=1,nsaxs
10253         Pcalc(k)=0.0d0
10254         do j=1,nres
10255           do l=1,3
10256             PgradC(k,l,j)=0.0d0
10257             PgradX(k,l,j)=0.0d0
10258           enddo
10259         enddo
10260       enddo
10261       do i=iatsc_s,iatsc_e
10262        if (itype(i).eq.ntyp1) cycle
10263        do iint=1,nint_gr(i)
10264          do j=istart(i,iint),iend(i,iint)
10265            if (itype(j).eq.ntyp1) cycle
10266 #ifdef ALLSAXS
10267            dijCACA=dist(i,j)
10268            dijCASC=dist(i,j+nres)
10269            dijSCCA=dist(i+nres,j)
10270            dijSCSC=dist(i+nres,j+nres)
10271            sigma2CACA=2.0d0/(pstok**2)
10272            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10273            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10274            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10275            do k=1,nsaxs
10276              dk = distsaxs(k)
10277              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10278              if (itype(j).ne.10) then
10279              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10280              else
10281              endif
10282              expCASC = 0.0d0
10283              if (itype(i).ne.10) then
10284              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10285              else
10286              expSCCA = 0.0d0
10287              endif
10288              if (itype(i).ne.10 .and. itype(j).ne.10) then
10289              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10290              else
10291              expSCSC = 0.0d0
10292              endif
10293              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10294 #ifdef DEBUG
10295              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10296 #endif
10297              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10298              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10299              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10300              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10301              do l=1,3
10302 c CA CA
10303                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10304                PgradC(k,l,i) = PgradC(k,l,i)-aux
10305                PgradC(k,l,j) = PgradC(k,l,j)+aux
10306 c CA SC
10307                if (itype(j).ne.10) then
10308                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10309                PgradC(k,l,i) = PgradC(k,l,i)-aux
10310                PgradC(k,l,j) = PgradC(k,l,j)+aux
10311                PgradX(k,l,j) = PgradX(k,l,j)+aux
10312                endif
10313 c SC CA
10314                if (itype(i).ne.10) then
10315                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10316                PgradX(k,l,i) = PgradX(k,l,i)-aux
10317                PgradC(k,l,i) = PgradC(k,l,i)-aux
10318                PgradC(k,l,j) = PgradC(k,l,j)+aux
10319                endif
10320 c SC SC
10321                if (itype(i).ne.10 .and. itype(j).ne.10) then
10322                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10323                PgradC(k,l,i) = PgradC(k,l,i)-aux
10324                PgradC(k,l,j) = PgradC(k,l,j)+aux
10325                PgradX(k,l,i) = PgradX(k,l,i)-aux
10326                PgradX(k,l,j) = PgradX(k,l,j)+aux
10327                endif
10328              enddo ! l
10329            enddo ! k
10330 #else
10331            dijCACA=dist(i,j)
10332            sigma2CACA=scal_rad**2*0.25d0/
10333      &        (restok(itype(j))**2+restok(itype(i))**2)
10334
10335            IF (saxs_cutoff.eq.0) THEN
10336            do k=1,nsaxs
10337              dk = distsaxs(k)
10338              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10339              Pcalc(k) = Pcalc(k)+expCACA
10340              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10341              do l=1,3
10342                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10343                PgradC(k,l,i) = PgradC(k,l,i)-aux
10344                PgradC(k,l,j) = PgradC(k,l,j)+aux
10345              enddo ! l
10346            enddo ! k
10347            ELSE
10348            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10349            do k=1,nsaxs
10350              dk = distsaxs(k)
10351 c             write (2,*) "ijk",i,j,k
10352              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10353              if (sss2.eq.0.0d0) cycle
10354              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10355              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10356              Pcalc(k) = Pcalc(k)+expCACA
10357 #ifdef DEBUG
10358              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10359 #endif
10360              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10361      &             ssgrad2*expCACA/sss2
10362              do l=1,3
10363 c CA CA
10364                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10365                PgradC(k,l,i) = PgradC(k,l,i)+aux
10366                PgradC(k,l,j) = PgradC(k,l,j)-aux
10367              enddo ! l
10368            enddo ! k
10369            ENDIF
10370 #endif
10371          enddo ! j
10372        enddo ! iint
10373       enddo ! i
10374 #ifdef MPI
10375       if (nfgtasks.gt.1) then
10376         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10377      &    MPI_SUM,king,FG_COMM,IERR)
10378         if (fg_rank.eq.king) then
10379           do k=1,nsaxs
10380             Pcalc(k) = Pcalc_(k)
10381           enddo
10382         endif
10383         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10385         if (fg_rank.eq.king) then
10386           do i=1,nres
10387             do l=1,3
10388               do k=1,nsaxs
10389                 PgradC(k,l,i) = PgradC_(k,l,i)
10390               enddo
10391             enddo
10392           enddo
10393         endif
10394 #ifdef ALLSAXS
10395         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10396      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10397         if (fg_rank.eq.king) then
10398           do i=1,nres
10399             do l=1,3
10400               do k=1,nsaxs
10401                 PgradX(k,l,i) = PgradX_(k,l,i)
10402               enddo
10403             enddo
10404           enddo
10405         endif
10406 #endif
10407       endif
10408 #endif
10409 #ifdef MPI
10410       if (fg_rank.eq.king) then
10411 #endif
10412       Cnorm = 0.0d0
10413       do k=1,nsaxs
10414         Cnorm = Cnorm + Pcalc(k)
10415       enddo
10416       Esaxs_constr = dlog(Cnorm)-wsaxs0
10417       do k=1,nsaxs
10418         if (Pcalc(k).gt.0.0d0)
10419      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10420 #ifdef DEBUG
10421         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10422 #endif
10423       enddo
10424 #ifdef DEBUG
10425       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10426 #endif
10427       do i=nnt,nct
10428         do l=1,3
10429           auxC=0.0d0
10430           auxC1=0.0d0
10431           auxX=0.0d0
10432           auxX1=0.d0
10433           do k=1,nsaxs
10434             if (Pcalc(k).gt.0)
10435      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10436             auxC1 = auxC1+PgradC(k,l,i)
10437 #ifdef ALLSAXS
10438             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10439             auxX1 = auxX1+PgradX(k,l,i)
10440 #endif
10441           enddo
10442           gsaxsC(l,i) = auxC - auxC1/Cnorm
10443 #ifdef ALLSAXS
10444           gsaxsX(l,i) = auxX - auxX1/Cnorm
10445 #endif
10446 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10447 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10448         enddo
10449       enddo
10450 #ifdef MPI
10451       endif
10452 #endif
10453       return
10454       end
10455 c----------------------------------------------------------------------------
10456       subroutine e_saxsC(Esaxs_constr)
10457       implicit none
10458       include 'DIMENSIONS'
10459       include 'DIMENSIONS.ZSCOPT'
10460       include 'DIMENSIONS.FREE'
10461 #ifdef MPI
10462       include "mpif.h"
10463       include "COMMON.SETUP"
10464       integer IERR
10465 #endif
10466       include 'COMMON.SBRIDGE'
10467       include 'COMMON.CHAIN'
10468       include 'COMMON.GEO'
10469       include 'COMMON.LOCAL'
10470       include 'COMMON.INTERACT'
10471       include 'COMMON.VAR'
10472       include 'COMMON.IOUNITS'
10473       include 'COMMON.DERIV'
10474       include 'COMMON.CONTROL'
10475       include 'COMMON.NAMES'
10476       include 'COMMON.FFIELD'
10477       include 'COMMON.LANGEVIN'
10478       include 'COMMON.SAXS'
10479 c
10480       double precision Esaxs_constr
10481       integer i,iint,j,k,l
10482       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10483 #ifdef MPI
10484       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10485 #endif
10486       double precision dk,dijCASPH,dijSCSPH,
10487      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10488      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10489      & auxX,auxX1,Cnorm
10490 c  SAXS restraint penalty function
10491 #ifdef DEBUG
10492       write(iout,*) "------- SAXS penalty function start -------"
10493       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10494      & " isaxs_end",isaxs_end
10495       write (iout,*) "nnt",nnt," ntc",nct
10496       do i=nnt,nct
10497         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10498      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10499       enddo
10500       do i=nnt,nct
10501         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10502       enddo
10503 #endif
10504       Esaxs_constr = 0.0d0
10505       logPtot=0.0d0
10506       do j=isaxs_start,isaxs_end
10507         Pcalc=0.0d0
10508         do i=1,nres
10509           do l=1,3
10510             PgradC(l,i)=0.0d0
10511             PgradX(l,i)=0.0d0
10512           enddo
10513         enddo
10514         do i=nnt,nct
10515           dijCASPH=0.0d0
10516           dijSCSPH=0.0d0
10517           do l=1,3
10518             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10519           enddo
10520           if (itype(i).ne.10) then
10521           do l=1,3
10522             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10523           enddo
10524           endif
10525           sigma2CA=2.0d0/pstok**2
10526           sigma2SC=4.0d0/restok(itype(i))**2
10527           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10528           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10529           Pcalc = Pcalc+expCASPH+expSCSPH
10530 #ifdef DEBUG
10531           write(*,*) "processor i j Pcalc",
10532      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10533 #endif
10534           CASPHgrad = sigma2CA*expCASPH
10535           SCSPHgrad = sigma2SC*expSCSPH
10536           do l=1,3
10537             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10538             PgradX(l,i) = PgradX(l,i) + aux
10539             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10540           enddo ! l
10541         enddo ! i
10542         do i=nnt,nct
10543           do l=1,3
10544             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10545             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10546           enddo
10547         enddo
10548         logPtot = logPtot - dlog(Pcalc)
10549 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10550 c     &    " logPtot",logPtot
10551       enddo ! j
10552 #ifdef MPI
10553       if (nfgtasks.gt.1) then
10554 c        write (iout,*) "logPtot before reduction",logPtot
10555         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10556      &    MPI_SUM,king,FG_COMM,IERR)
10557         logPtot = logPtot_
10558 c        write (iout,*) "logPtot after reduction",logPtot
10559         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10560      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10561         if (fg_rank.eq.king) then
10562           do i=1,nres
10563             do l=1,3
10564               gsaxsC(l,i) = gsaxsC_(l,i)
10565             enddo
10566           enddo
10567         endif
10568         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10569      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10570         if (fg_rank.eq.king) then
10571           do i=1,nres
10572             do l=1,3
10573               gsaxsX(l,i) = gsaxsX_(l,i)
10574             enddo
10575           enddo
10576         endif
10577       endif
10578 #endif
10579       Esaxs_constr = logPtot
10580       return
10581       end
10582