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 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1220 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
1221 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1222             xj=boxshift(xj-xi,boxxsize)
1223             yj=boxshift(yj-yi,boxysize)
1224             zj=boxshift(zj-zi,boxzsize)
1225             dxj=dc_norm(1,nres+j)
1226             dyj=dc_norm(2,nres+j)
1227             dzj=dc_norm(3,nres+j)
1228 c            write (iout,*) i,j,xj,yj,zj
1229             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1230             rij=dsqrt(rrij)
1231             sss=sscale(1.0d0/rij)
1232             sssgrad=sscagrad(1.0d0/rij)
1233             if (sss.le.0.0) cycle
1234 C Calculate angle-dependent terms of energy and contributions to their
1235 C derivatives.
1236
1237             call sc_angular
1238             sigsq=1.0D0/sigsq
1239             sig=sig0ij*dsqrt(sigsq)
1240             rij_shift=1.0D0/rij-sig+sig0ij
1241 C I hate to put IF's in the loops, but here don't have another choice!!!!
1242             if (rij_shift.le.0.0D0) then
1243               evdw=1.0D20
1244               return
1245             endif
1246             sigder=-sig*sigsq
1247 c---------------------------------------------------------------
1248             rij_shift=1.0D0/rij_shift
1249             fac=rij_shift**expon
1250             e1=fac*fac*aa
1251             e2=fac*bb
1252             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1253             eps2der=evdwij*eps3rt
1254             eps3der=evdwij*eps2rt
1255             evdwij=evdwij*eps2rt*eps3rt
1256             if (bb.gt.0) then
1257               evdw=evdw+evdwij*sss
1258             else
1259               evdw_t=evdw_t+evdwij*sss
1260             endif
1261             ij=icant(itypi,itypj)
1262             aux=eps1*eps2rt**2*eps3rt**2
1263             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1264      &        /dabs(eps(itypi,itypj))
1265             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1266 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1267 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1268 c     &         aux*e2/eps(itypi,itypj)
1269 c            if (lprn) then
1270             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1271             epsi=bb**2/aa
1272 c#define DEBUG
1273 #ifdef DEBUG
1274             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1275      &        restyp(itypi),i,restyp(itypj),j,
1276      &        epsi,sigm,chi1,chi2,chip1,chip2,
1277      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1278      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1279      &        evdwij
1280              write (iout,*) "partial sum", evdw, evdw_t
1281 #endif
1282 c#undef DEBUG
1283 c            endif
1284             if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
1285      &       'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
1286             if (calc_grad) then
1287 C Calculate gradient components.
1288             e1=e1*eps1*eps2rt**2*eps3rt**2
1289             fac=-expon*(e1+evdwij)*rij_shift
1290             sigder=fac*sigder
1291             fac=rij*fac
1292             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1293 C Calculate the radial part of the gradient
1294             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1295      &        *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1296      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1297      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1298             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1299             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1300             gg(1)=xj*fac
1301             gg(2)=yj*fac
1302             gg(3)=zj*fac
1303 C Calculate angular part of the gradient.
1304             call sc_grad
1305             endif
1306 C            write(iout,*)  "partial sum", evdw, evdw_t
1307             ENDIF    ! dyn_ss
1308           enddo      ! j
1309         enddo        ! iint
1310       enddo          ! i
1311       return
1312       end
1313 C-----------------------------------------------------------------------------
1314       subroutine egbv(evdw,evdw_t)
1315 C
1316 C This subroutine calculates the interaction energy of nonbonded side chains
1317 C assuming the Gay-Berne-Vorobjev potential of interaction.
1318 C
1319       implicit real*8 (a-h,o-z)
1320       include 'DIMENSIONS'
1321       include 'DIMENSIONS.ZSCOPT'
1322       include "DIMENSIONS.COMPAR"
1323       include 'COMMON.GEO'
1324       include 'COMMON.VAR'
1325       include 'COMMON.LOCAL'
1326       include 'COMMON.CHAIN'
1327       include 'COMMON.DERIV'
1328       include 'COMMON.NAMES'
1329       include 'COMMON.INTERACT'
1330       include 'COMMON.ENEPS'
1331       include 'COMMON.IOUNITS'
1332       include 'COMMON.CALC'
1333       common /srutu/ icall
1334       logical lprn
1335       integer icant
1336       external icant
1337       do i=1,210
1338         do j=1,2
1339           eneps_temp(j,i)=0.0d0
1340         enddo
1341       enddo
1342       evdw=0.0D0
1343       evdw_t=0.0d0
1344 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1345       evdw=0.0D0
1346       lprn=.false.
1347 c      if (icall.gt.0) lprn=.true.
1348       ind=0
1349       do i=iatsc_s,iatsc_e
1350         itypi=iabs(itype(i))
1351         if (itypi.eq.ntyp1) cycle
1352         itypi1=iabs(itype(i+1))
1353         xi=c(1,nres+i)
1354         yi=c(2,nres+i)
1355         zi=c(3,nres+i)
1356         call to_box(xi,yi,zi)
1357         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1358         dxi=dc_norm(1,nres+i)
1359         dyi=dc_norm(2,nres+i)
1360         dzi=dc_norm(3,nres+i)
1361         dsci_inv=vbld_inv(i+nres)
1362 C
1363 C Calculate SC interaction energy.
1364 C
1365         do iint=1,nint_gr(i)
1366           do j=istart(i,iint),iend(i,iint)
1367             ind=ind+1
1368             itypj=iabs(itype(j))
1369             if (itypj.eq.ntyp1) cycle
1370             dscj_inv=vbld_inv(j+nres)
1371             sig0ij=sigma(itypi,itypj)
1372             r0ij=r0(itypi,itypj)
1373             chi1=chi(itypi,itypj)
1374             chi2=chi(itypj,itypi)
1375             chi12=chi1*chi2
1376             chip1=chip(itypi)
1377             chip2=chip(itypj)
1378             chip12=chip1*chip2
1379             alf1=alp(itypi)
1380             alf2=alp(itypj)
1381             alf12=0.5D0*(alf1+alf2)
1382 C For diagnostics only!!!
1383 c           chi1=0.0D0
1384 c           chi2=0.0D0
1385 c           chi12=0.0D0
1386 c           chip1=0.0D0
1387 c           chip2=0.0D0
1388 c           chip12=0.0D0
1389 c           alf1=0.0D0
1390 c           alf2=0.0D0
1391 c           alf12=0.0D0
1392             xj=c(1,nres+j)
1393             yj=c(2,nres+j)
1394             zj=c(3,nres+j)
1395             call to_box(xj,yj,zj)
1396             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1397             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1398      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1399             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1400      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1401 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1402 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1403 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
1404             xj=boxshift(xj-xi,boxxsize)
1405             yj=boxshift(yj-yi,boxysize)
1406             zj=boxshift(zj-zi,boxzsize)
1407             dxj=dc_norm(1,nres+j)
1408             dyj=dc_norm(2,nres+j)
1409             dzj=dc_norm(3,nres+j)
1410             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1411             rij=dsqrt(rrij)
1412             sss=sscale(1.0d0/rij)
1413             if (sss.eq.0.0d0) cycle
1414             sssgrad=sscagrad(1.0d0/rij)
1415 C Calculate angle-dependent terms of energy and contributions to their
1416 C derivatives.
1417             call sc_angular
1418             sigsq=1.0D0/sigsq
1419             sig=sig0ij*dsqrt(sigsq)
1420             rij_shift=1.0D0/rij-sig+r0ij
1421 C I hate to put IF's in the loops, but here don't have another choice!!!!
1422             if (rij_shift.le.0.0D0) then
1423               evdw=1.0D20
1424               return
1425             endif
1426             sigder=-sig*sigsq
1427 c---------------------------------------------------------------
1428             rij_shift=1.0D0/rij_shift
1429             fac=rij_shift**expon
1430             e1=fac*fac*aa
1431             e2=fac*bb
1432             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1433             eps2der=evdwij*eps3rt
1434             eps3der=evdwij*eps2rt
1435             fac_augm=rrij**expon
1436             e_augm=augm(itypi,itypj)*fac_augm
1437             evdwij=evdwij*eps2rt*eps3rt
1438             if (bb.gt.0.0d0) then
1439               evdw=evdw+(evdwij+e_augm)*sss
1440             else
1441               evdw_t=evdw_t+(evdwij+e_augm)*sss
1442             endif
1443             ij=icant(itypi,itypj)
1444             aux=eps1*eps2rt**2*eps3rt**2
1445             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1446      &        /dabs(eps(itypi,itypj))
1447             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1448 c            eneps_temp(ij)=eneps_temp(ij)
1449 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1450 c            if (lprn) then
1451 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1452 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1453 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1454 c     &        restyp(itypi),i,restyp(itypj),j,
1455 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1456 c     &        chi1,chi2,chip1,chip2,
1457 c     &        eps1,eps2rt**2,eps3rt**2,
1458 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1459 c     &        evdwij+e_augm
1460 c            endif
1461             if (calc_grad) then
1462 C Calculate gradient components.
1463             e1=e1*eps1*eps2rt**2*eps3rt**2
1464             fac=-expon*(e1+evdwij)*rij_shift
1465             sigder=fac*sigder
1466             fac=rij*fac-2*expon*rrij*e_augm
1467             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1468 C Calculate the radial part of the gradient
1469             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1470      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1471      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1472      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1473             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1474             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1475             gg(1)=xj*fac
1476             gg(2)=yj*fac
1477             gg(3)=zj*fac
1478 C Calculate angular part of the gradient.
1479             call sc_grad
1480             endif
1481           enddo      ! j
1482         enddo        ! iint
1483       enddo          ! i
1484       return
1485       end
1486 C-----------------------------------------------------------------------------
1487       subroutine sc_angular
1488 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1489 C om12. Called by ebp, egb, and egbv.
1490       implicit none
1491       include 'COMMON.CALC'
1492       erij(1)=xj*rij
1493       erij(2)=yj*rij
1494       erij(3)=zj*rij
1495       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1496       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1497       om12=dxi*dxj+dyi*dyj+dzi*dzj
1498       chiom12=chi12*om12
1499 C Calculate eps1(om12) and its derivative in om12
1500       faceps1=1.0D0-om12*chiom12
1501       faceps1_inv=1.0D0/faceps1
1502       eps1=dsqrt(faceps1_inv)
1503 C Following variable is eps1*deps1/dom12
1504       eps1_om12=faceps1_inv*chiom12
1505 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1506 C and om12.
1507       om1om2=om1*om2
1508       chiom1=chi1*om1
1509       chiom2=chi2*om2
1510       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1511       sigsq=1.0D0-facsig*faceps1_inv
1512       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1513       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1514       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1515 C Calculate eps2 and its derivatives in om1, om2, and om12.
1516       chipom1=chip1*om1
1517       chipom2=chip2*om2
1518       chipom12=chip12*om12
1519       facp=1.0D0-om12*chipom12
1520       facp_inv=1.0D0/facp
1521       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1522 C Following variable is the square root of eps2
1523       eps2rt=1.0D0-facp1*facp_inv
1524 C Following three variables are the derivatives of the square root of eps
1525 C in om1, om2, and om12.
1526       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1527       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1528       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1529 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1530       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1531 C Calculate whole angle-dependent part of epsilon and contributions
1532 C to its derivatives
1533       return
1534       end
1535 C----------------------------------------------------------------------------
1536       subroutine sc_grad
1537       implicit real*8 (a-h,o-z)
1538       include 'DIMENSIONS'
1539       include 'DIMENSIONS.ZSCOPT'
1540       include 'COMMON.CHAIN'
1541       include 'COMMON.DERIV'
1542       include 'COMMON.CALC'
1543       double precision dcosom1(3),dcosom2(3)
1544       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1545       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1546       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1547      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1548       do k=1,3
1549         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1550         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1551       enddo
1552       do k=1,3
1553         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1554       enddo
1555       do k=1,3
1556         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1557      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1558      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1559         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1561      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1562       enddo
1563 C
1564 C Calculate the components of the gradient in DC and X
1565 C
1566       do k=i,j-1
1567         do l=1,3
1568           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1569         enddo
1570       enddo
1571       return
1572       end
1573 c------------------------------------------------------------------------------
1574       subroutine vec_and_deriv
1575       implicit real*8 (a-h,o-z)
1576       include 'DIMENSIONS'
1577       include 'DIMENSIONS.ZSCOPT'
1578       include 'COMMON.IOUNITS'
1579       include 'COMMON.GEO'
1580       include 'COMMON.VAR'
1581       include 'COMMON.LOCAL'
1582       include 'COMMON.CHAIN'
1583       include 'COMMON.VECTORS'
1584       include 'COMMON.DERIV'
1585       include 'COMMON.INTERACT'
1586       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1587 C Compute the local reference systems. For reference system (i), the
1588 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1589 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1590       do i=1,nres-1
1591 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1592           if (i.eq.nres-1) then
1593 C Case of the last full residue
1594 C Compute the Z-axis
1595             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1596             costh=dcos(pi-theta(nres))
1597             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1598 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1599 c     &         " uz",uz(:,i)
1600             do k=1,3
1601               uz(k,i)=fac*uz(k,i)
1602             enddo
1603             if (calc_grad) then
1604 C Compute the derivatives of uz
1605             uzder(1,1,1)= 0.0d0
1606             uzder(2,1,1)=-dc_norm(3,i-1)
1607             uzder(3,1,1)= dc_norm(2,i-1)
1608             uzder(1,2,1)= dc_norm(3,i-1)
1609             uzder(2,2,1)= 0.0d0
1610             uzder(3,2,1)=-dc_norm(1,i-1)
1611             uzder(1,3,1)=-dc_norm(2,i-1)
1612             uzder(2,3,1)= dc_norm(1,i-1)
1613             uzder(3,3,1)= 0.0d0
1614             uzder(1,1,2)= 0.0d0
1615             uzder(2,1,2)= dc_norm(3,i)
1616             uzder(3,1,2)=-dc_norm(2,i)
1617             uzder(1,2,2)=-dc_norm(3,i)
1618             uzder(2,2,2)= 0.0d0
1619             uzder(3,2,2)= dc_norm(1,i)
1620             uzder(1,3,2)= dc_norm(2,i)
1621             uzder(2,3,2)=-dc_norm(1,i)
1622             uzder(3,3,2)= 0.0d0
1623             endif ! calc_grad
1624 C Compute the Y-axis
1625             facy=fac
1626             do k=1,3
1627               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1628             enddo
1629             if (calc_grad) then
1630 C Compute the derivatives of uy
1631             do j=1,3
1632               do k=1,3
1633                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1634      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1635                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1636               enddo
1637               uyder(j,j,1)=uyder(j,j,1)-costh
1638               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1639             enddo
1640             do j=1,2
1641               do k=1,3
1642                 do l=1,3
1643                   uygrad(l,k,j,i)=uyder(l,k,j)
1644                   uzgrad(l,k,j,i)=uzder(l,k,j)
1645                 enddo
1646               enddo
1647             enddo
1648             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1649             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1650             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1651             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1652             endif
1653           else
1654 C Other residues
1655 C Compute the Z-axis
1656             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1657             costh=dcos(pi-theta(i+2))
1658             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1659             do k=1,3
1660               uz(k,i)=fac*uz(k,i)
1661             enddo
1662             if (calc_grad) then
1663 C Compute the derivatives of uz
1664             uzder(1,1,1)= 0.0d0
1665             uzder(2,1,1)=-dc_norm(3,i+1)
1666             uzder(3,1,1)= dc_norm(2,i+1)
1667             uzder(1,2,1)= dc_norm(3,i+1)
1668             uzder(2,2,1)= 0.0d0
1669             uzder(3,2,1)=-dc_norm(1,i+1)
1670             uzder(1,3,1)=-dc_norm(2,i+1)
1671             uzder(2,3,1)= dc_norm(1,i+1)
1672             uzder(3,3,1)= 0.0d0
1673             uzder(1,1,2)= 0.0d0
1674             uzder(2,1,2)= dc_norm(3,i)
1675             uzder(3,1,2)=-dc_norm(2,i)
1676             uzder(1,2,2)=-dc_norm(3,i)
1677             uzder(2,2,2)= 0.0d0
1678             uzder(3,2,2)= dc_norm(1,i)
1679             uzder(1,3,2)= dc_norm(2,i)
1680             uzder(2,3,2)=-dc_norm(1,i)
1681             uzder(3,3,2)= 0.0d0
1682             endif
1683 C Compute the Y-axis
1684             facy=fac
1685             do k=1,3
1686               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1687             enddo
1688             if (calc_grad) then
1689 C Compute the derivatives of uy
1690             do j=1,3
1691               do k=1,3
1692                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1693      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1694                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1695               enddo
1696               uyder(j,j,1)=uyder(j,j,1)-costh
1697               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1698             enddo
1699             do j=1,2
1700               do k=1,3
1701                 do l=1,3
1702                   uygrad(l,k,j,i)=uyder(l,k,j)
1703                   uzgrad(l,k,j,i)=uzder(l,k,j)
1704                 enddo
1705               enddo
1706             enddo
1707             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1708             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1709             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1710             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1711           endif
1712           endif
1713       enddo
1714       if (calc_grad) then
1715       do i=1,nres-1
1716         vbld_inv_temp(1)=vbld_inv(i+1)
1717         if (i.lt.nres-1) then
1718           vbld_inv_temp(2)=vbld_inv(i+2)
1719         else
1720           vbld_inv_temp(2)=vbld_inv(i)
1721         endif
1722         do j=1,2
1723           do k=1,3
1724             do l=1,3
1725               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1726               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1727             enddo
1728           enddo
1729         enddo
1730       enddo
1731       endif
1732       return
1733       end
1734 C--------------------------------------------------------------------------
1735       subroutine set_matrices
1736       implicit real*8 (a-h,o-z)
1737       include 'DIMENSIONS'
1738 #ifdef MPI
1739       include "mpif.h"
1740       integer IERR
1741       integer status(MPI_STATUS_SIZE)
1742 #endif
1743       include 'DIMENSIONS.ZSCOPT'
1744       include 'COMMON.IOUNITS'
1745       include 'COMMON.GEO'
1746       include 'COMMON.VAR'
1747       include 'COMMON.LOCAL'
1748       include 'COMMON.CHAIN'
1749       include 'COMMON.DERIV'
1750       include 'COMMON.INTERACT'
1751       include 'COMMON.CORRMAT'
1752       include 'COMMON.TORSION'
1753       include 'COMMON.VECTORS'
1754       include 'COMMON.FFIELD'
1755       double precision auxvec(2),auxmat(2,2)
1756 C
1757 C Compute the virtual-bond-torsional-angle dependent quantities needed
1758 C to calculate the el-loc multibody terms of various order.
1759 C
1760 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1761       do i=3,nres+1
1762         ii=ireschain(i-2)
1763         if (ii.eq.0) cycle
1764         innt=chain_border(1,ii)
1765         inct=chain_border(2,ii)
1766 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1767         if (i.gt. innt+2 .and. i.lt.inct+2) then
1768           iti = itype2loc(itype(i-2))
1769         else
1770           iti=nloctyp
1771         endif
1772 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1773 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1774         if (i.gt. innt+1 .and. i.lt.inct+1) then
1775           iti1 = itype2loc(itype(i-1))
1776         else
1777           iti1=nloctyp
1778         endif
1779 #ifdef NEWCORR
1780         cost1=dcos(theta(i-1))
1781         sint1=dsin(theta(i-1))
1782         sint1sq=sint1*sint1
1783         sint1cub=sint1sq*sint1
1784         sint1cost1=2*sint1*cost1
1785 #ifdef DEBUG
1786         write (iout,*) "bnew1",i,iti
1787         write (iout,*) (bnew1(k,1,iti),k=1,3)
1788         write (iout,*) (bnew1(k,2,iti),k=1,3)
1789         write (iout,*) "bnew2",i,iti
1790         write (iout,*) (bnew2(k,1,iti),k=1,3)
1791         write (iout,*) (bnew2(k,2,iti),k=1,3)
1792 #endif
1793         do k=1,2
1794           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1795           b1(k,i-2)=sint1*b1k
1796           gtb1(k,i-2)=cost1*b1k-sint1sq*
1797      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1798           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1799           b2(k,i-2)=sint1*b2k
1800           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1801      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1802         enddo
1803         do k=1,2
1804           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1805           cc(1,k,i-2)=sint1sq*aux
1806           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1807      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1808           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1809           dd(1,k,i-2)=sint1sq*aux
1810           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1811      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1812         enddo
1813         cc(2,1,i-2)=cc(1,2,i-2)
1814         cc(2,2,i-2)=-cc(1,1,i-2)
1815         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1816         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1817         dd(2,1,i-2)=dd(1,2,i-2)
1818         dd(2,2,i-2)=-dd(1,1,i-2)
1819         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1820         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1821         do k=1,2
1822           do l=1,2
1823             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1824             EE(l,k,i-2)=sint1sq*aux
1825             if (calc_grad)
1826      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1827           enddo
1828         enddo
1829         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1830         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1831         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1832         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1833         if (calc_grad) then
1834         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1835         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1836         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1837         endif
1838 c        b1tilde(1,i-2)=b1(1,i-2)
1839 c        b1tilde(2,i-2)=-b1(2,i-2)
1840 c        b2tilde(1,i-2)=b2(1,i-2)
1841 c        b2tilde(2,i-2)=-b2(2,i-2)
1842 #ifdef DEBUG
1843         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1844         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1845         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1846         write (iout,*) 'theta=', theta(i-1)
1847 #endif
1848 #else
1849 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1850 c          iti = itype2loc(itype(i-2))
1851 c        else
1852 c          iti=nloctyp
1853 c        endif
1854 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1855 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1856 c          iti1 = itype2loc(itype(i-1))
1857 c        else
1858 c          iti1=nloctyp
1859 c        endif
1860         b1(1,i-2)=b(3,iti)
1861         b1(2,i-2)=b(5,iti)
1862         b2(1,i-2)=b(2,iti)
1863         b2(2,i-2)=b(4,iti)
1864         do k=1,2
1865           do l=1,2
1866            CC(k,l,i-2)=ccold(k,l,iti)
1867            DD(k,l,i-2)=ddold(k,l,iti)
1868            EE(k,l,i-2)=eeold(k,l,iti)
1869           enddo
1870         enddo
1871 #endif
1872         b1tilde(1,i-2)= b1(1,i-2)
1873         b1tilde(2,i-2)=-b1(2,i-2)
1874         b2tilde(1,i-2)= b2(1,i-2)
1875         b2tilde(2,i-2)=-b2(2,i-2)
1876 c
1877         Ctilde(1,1,i-2)= CC(1,1,i-2)
1878         Ctilde(1,2,i-2)= CC(1,2,i-2)
1879         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1880         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1881 c
1882         Dtilde(1,1,i-2)= DD(1,1,i-2)
1883         Dtilde(1,2,i-2)= DD(1,2,i-2)
1884         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1885         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1886 #ifdef DEBUG
1887         write(iout,*) "i",i," iti",iti
1888         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1889         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1890 #endif
1891       enddo
1892       do i=3,nres+1
1893         if (i .lt. nres+1) then
1894           sin1=dsin(phi(i))
1895           cos1=dcos(phi(i))
1896           sintab(i-2)=sin1
1897           costab(i-2)=cos1
1898           obrot(1,i-2)=cos1
1899           obrot(2,i-2)=sin1
1900           sin2=dsin(2*phi(i))
1901           cos2=dcos(2*phi(i))
1902           sintab2(i-2)=sin2
1903           costab2(i-2)=cos2
1904           obrot2(1,i-2)=cos2
1905           obrot2(2,i-2)=sin2
1906           Ug(1,1,i-2)=-cos1
1907           Ug(1,2,i-2)=-sin1
1908           Ug(2,1,i-2)=-sin1
1909           Ug(2,2,i-2)= cos1
1910           Ug2(1,1,i-2)=-cos2
1911           Ug2(1,2,i-2)=-sin2
1912           Ug2(2,1,i-2)=-sin2
1913           Ug2(2,2,i-2)= cos2
1914         else
1915           costab(i-2)=1.0d0
1916           sintab(i-2)=0.0d0
1917           obrot(1,i-2)=1.0d0
1918           obrot(2,i-2)=0.0d0
1919           obrot2(1,i-2)=0.0d0
1920           obrot2(2,i-2)=0.0d0
1921           Ug(1,1,i-2)=1.0d0
1922           Ug(1,2,i-2)=0.0d0
1923           Ug(2,1,i-2)=0.0d0
1924           Ug(2,2,i-2)=1.0d0
1925           Ug2(1,1,i-2)=0.0d0
1926           Ug2(1,2,i-2)=0.0d0
1927           Ug2(2,1,i-2)=0.0d0
1928           Ug2(2,2,i-2)=0.0d0
1929         endif
1930         if (i .gt. 3 .and. i .lt. nres+1) then
1931           obrot_der(1,i-2)=-sin1
1932           obrot_der(2,i-2)= cos1
1933           Ugder(1,1,i-2)= sin1
1934           Ugder(1,2,i-2)=-cos1
1935           Ugder(2,1,i-2)=-cos1
1936           Ugder(2,2,i-2)=-sin1
1937           dwacos2=cos2+cos2
1938           dwasin2=sin2+sin2
1939           obrot2_der(1,i-2)=-dwasin2
1940           obrot2_der(2,i-2)= dwacos2
1941           Ug2der(1,1,i-2)= dwasin2
1942           Ug2der(1,2,i-2)=-dwacos2
1943           Ug2der(2,1,i-2)=-dwacos2
1944           Ug2der(2,2,i-2)=-dwasin2
1945         else
1946           obrot_der(1,i-2)=0.0d0
1947           obrot_der(2,i-2)=0.0d0
1948           Ugder(1,1,i-2)=0.0d0
1949           Ugder(1,2,i-2)=0.0d0
1950           Ugder(2,1,i-2)=0.0d0
1951           Ugder(2,2,i-2)=0.0d0
1952           obrot2_der(1,i-2)=0.0d0
1953           obrot2_der(2,i-2)=0.0d0
1954           Ug2der(1,1,i-2)=0.0d0
1955           Ug2der(1,2,i-2)=0.0d0
1956           Ug2der(2,1,i-2)=0.0d0
1957           Ug2der(2,2,i-2)=0.0d0
1958         endif
1959 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1960         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1961           iti = itype2loc(itype(i-2))
1962         else
1963           iti=nloctyp
1964         endif
1965 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1966         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1967           iti1 = itype2loc(itype(i-1))
1968         else
1969           iti1=nloctyp
1970         endif
1971 cd        write (iout,*) '*******i',i,' iti1',iti
1972 cd        write (iout,*) 'b1',b1(:,iti)
1973 cd        write (iout,*) 'b2',b2(:,iti)
1974 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1975 c        if (i .gt. iatel_s+2) then
1976         if (i .gt. nnt+2) then
1977           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1978 #ifdef NEWCORR
1979           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1980 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1981 #endif
1982 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1983 c     &    EE(1,2,iti),EE(2,2,i)
1984           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1985           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1986 c          write(iout,*) "Macierz EUG",
1987 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1988 c     &    eug(2,2,i-2)
1989 #ifdef FOURBODY
1990           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1991      &    then
1992           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1993           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1994           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1995           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1996           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1997           endif
1998 #endif
1999         else
2000           do k=1,2
2001             Ub2(k,i-2)=0.0d0
2002             Ctobr(k,i-2)=0.0d0
2003             Dtobr2(k,i-2)=0.0d0
2004             do l=1,2
2005               EUg(l,k,i-2)=0.0d0
2006               CUg(l,k,i-2)=0.0d0
2007               DUg(l,k,i-2)=0.0d0
2008               DtUg2(l,k,i-2)=0.0d0
2009             enddo
2010           enddo
2011         endif
2012         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2013         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2014         do k=1,2
2015           muder(k,i-2)=Ub2der(k,i-2)
2016         enddo
2017 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2018         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2019           if (itype(i-1).le.ntyp) then
2020             iti1 = itype2loc(itype(i-1))
2021           else
2022             iti1=nloctyp
2023           endif
2024         else
2025           iti1=nloctyp
2026         endif
2027         do k=1,2
2028           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2029         enddo
2030 #ifdef MUOUT
2031         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2032      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2033      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2034      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2035      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2036      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2037 #endif
2038 cd        write (iout,*) 'mu1',mu1(:,i-2)
2039 cd        write (iout,*) 'mu2',mu2(:,i-2)
2040 #ifdef FOURBODY
2041         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2042      &  then
2043         if (calc_grad) then
2044         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2045         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2046         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2047         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2048         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2049         endif
2050 C Vectors and matrices dependent on a single virtual-bond dihedral.
2051         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2052         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2053         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2054         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2055         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2056         if (calc_grad) then
2057         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2058         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2059         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2060         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2061         endif
2062         endif
2063 #endif
2064       enddo
2065 #ifdef FOURBODY
2066 C Matrices dependent on two consecutive virtual-bond dihedrals.
2067 C The order of matrices is from left to right.
2068       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2069      &then
2070       do i=2,nres-1
2071         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2072         if (calc_grad) then
2073         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2074         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2075         endif
2076         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2077         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2078         if (calc_grad) then
2079         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2080         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2081         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2082         endif
2083       enddo
2084       endif
2085 #endif
2086       return
2087       end
2088 C--------------------------------------------------------------------------
2089       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2090 C
2091 C This subroutine calculates the average interaction energy and its gradient
2092 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2093 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2094 C The potential depends both on the distance of peptide-group centers and on
2095 C the orientation of the CA-CA virtual bonds.
2096 C
2097       implicit real*8 (a-h,o-z)
2098 #ifdef MPI
2099       include 'mpif.h'
2100 #endif
2101       include 'DIMENSIONS'
2102       include 'DIMENSIONS.ZSCOPT'
2103       include 'COMMON.CONTROL'
2104       include 'COMMON.IOUNITS'
2105       include 'COMMON.GEO'
2106       include 'COMMON.VAR'
2107       include 'COMMON.LOCAL'
2108       include 'COMMON.CHAIN'
2109       include 'COMMON.DERIV'
2110       include 'COMMON.INTERACT'
2111 #ifdef FOURBODY
2112       include 'COMMON.CONTACTS'
2113       include 'COMMON.CONTMAT'
2114 #endif
2115       include 'COMMON.CORRMAT'
2116       include 'COMMON.TORSION'
2117       include 'COMMON.VECTORS'
2118       include 'COMMON.FFIELD'
2119       include 'COMMON.TIME1'
2120       include 'COMMON.SPLITELE'
2121       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2122      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2123       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2124      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2125       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2126      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2127      &    num_conti,j1,j2
2128       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
2129       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
2130 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2131 #ifdef MOMENT
2132       double precision scal_el /1.0d0/
2133 #else
2134       double precision scal_el /0.5d0/
2135 #endif
2136 C 12/13/98
2137 C 13-go grudnia roku pamietnego...
2138       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2139      &                   0.0d0,1.0d0,0.0d0,
2140      &                   0.0d0,0.0d0,1.0d0/
2141 cd      write(iout,*) 'In EELEC'
2142 cd      do i=1,nloctyp
2143 cd        write(iout,*) 'Type',i
2144 cd        write(iout,*) 'B1',B1(:,i)
2145 cd        write(iout,*) 'B2',B2(:,i)
2146 cd        write(iout,*) 'CC',CC(:,:,i)
2147 cd        write(iout,*) 'DD',DD(:,:,i)
2148 cd        write(iout,*) 'EE',EE(:,:,i)
2149 cd      enddo
2150 cd      call check_vecgrad
2151 cd      stop
2152       if (icheckgrad.eq.1) then
2153         do i=1,nres-1
2154           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2155           do k=1,3
2156             dc_norm(k,i)=dc(k,i)*fac
2157           enddo
2158 c          write (iout,*) 'i',i,' fac',fac
2159         enddo
2160       endif
2161       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2162      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2163      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2164 c        call vec_and_deriv
2165 #ifdef TIMING
2166         time01=MPI_Wtime()
2167 #endif
2168         call set_matrices
2169 #ifdef TIMING
2170         time_mat=time_mat+MPI_Wtime()-time01
2171 #endif
2172       endif
2173 cd      do i=1,nres-1
2174 cd        write (iout,*) 'i=',i
2175 cd        do k=1,3
2176 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2177 cd        enddo
2178 cd        do k=1,3
2179 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2180 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2181 cd        enddo
2182 cd      enddo
2183       t_eelecij=0.0d0
2184       ees=0.0D0
2185       evdw1=0.0D0
2186       eel_loc=0.0d0
2187       eello_turn3=0.0d0
2188       eello_turn4=0.0d0
2189       ind=0
2190 #ifdef FOURBODY
2191       do i=1,nres
2192         num_cont_hb(i)=0
2193       enddo
2194 #endif
2195 cd      print '(a)','Enter EELEC'
2196 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2197       do i=1,nres
2198         gel_loc_loc(i)=0.0d0
2199         gcorr_loc(i)=0.0d0
2200       enddo
2201 c
2202 c
2203 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2204 C
2205 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2206 C
2207 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2208       do i=iturn3_start,iturn3_end
2209 c        if (i.le.1) cycle
2210 C        write(iout,*) "tu jest i",i
2211         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2212 C changes suggested by Ana to avoid out of bounds
2213 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2214 c     & .or.((i+4).gt.nres)
2215 c     & .or.((i-1).le.0)
2216 C end of changes by Ana
2217 C dobra zmiana wycofana
2218      &  .or. itype(i+2).eq.ntyp1
2219      &  .or. itype(i+3).eq.ntyp1) cycle
2220 C Adam: Instructions below will switch off existing interactions
2221 c        if(i.gt.1)then
2222 c          if(itype(i-1).eq.ntyp1)cycle
2223 c        end if
2224 c        if(i.LT.nres-3)then
2225 c          if (itype(i+4).eq.ntyp1) cycle
2226 c        end if
2227         dxi=dc(1,i)
2228         dyi=dc(2,i)
2229         dzi=dc(3,i)
2230         dx_normi=dc_norm(1,i)
2231         dy_normi=dc_norm(2,i)
2232         dz_normi=dc_norm(3,i)
2233         xmedi=c(1,i)+0.5d0*dxi
2234         ymedi=c(2,i)+0.5d0*dyi
2235         zmedi=c(3,i)+0.5d0*dzi
2236         call to_box(xmedi,ymedi,zmedi)
2237         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2238         num_conti=0
2239         call eelecij(i,i+2,ees,evdw1,eel_loc)
2240         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2241 #ifdef FOURBODY
2242         num_cont_hb(i)=num_conti
2243 #endif
2244       enddo
2245       do i=iturn4_start,iturn4_end
2246         if (i.lt.1) cycle
2247         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2248 C changes suggested by Ana to avoid out of bounds
2249 c     & .or.((i+5).gt.nres)
2250 c     & .or.((i-1).le.0)
2251 C end of changes suggested by Ana
2252      &    .or. itype(i+3).eq.ntyp1
2253      &    .or. itype(i+4).eq.ntyp1
2254 c     &    .or. itype(i+5).eq.ntyp1
2255 c     &    .or. itype(i).eq.ntyp1
2256 c     &    .or. itype(i-1).eq.ntyp1
2257      &                             ) cycle
2258         dxi=dc(1,i)
2259         dyi=dc(2,i)
2260         dzi=dc(3,i)
2261         dx_normi=dc_norm(1,i)
2262         dy_normi=dc_norm(2,i)
2263         dz_normi=dc_norm(3,i)
2264         xmedi=c(1,i)+0.5d0*dxi
2265         ymedi=c(2,i)+0.5d0*dyi
2266         zmedi=c(3,i)+0.5d0*dzi
2267         call to_box(xmedi,ymedi,zmedi)
2268         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2269 #ifdef FOURBODY
2270         num_conti=num_cont_hb(i)
2271 #endif
2272 c        write(iout,*) "JESTEM W PETLI"
2273         call eelecij(i,i+3,ees,evdw1,eel_loc)
2274         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2275      &   call eturn4(i,eello_turn4)
2276 #ifdef FOURBODY
2277         num_cont_hb(i)=num_conti
2278 #endif
2279       enddo   ! i
2280 C Loop over all neighbouring boxes
2281 C      do xshift=-1,1
2282 C      do yshift=-1,1
2283 C      do zshift=-1,1
2284 c
2285 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2286 c
2287 CTU KURWA
2288       do i=iatel_s,iatel_e
2289 C        do i=75,75
2290 c        if (i.le.1) cycle
2291         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2292 C changes suggested by Ana to avoid out of bounds
2293 c     & .or.((i+2).gt.nres)
2294 c     & .or.((i-1).le.0)
2295 C end of changes by Ana
2296 c     &  .or. itype(i+2).eq.ntyp1
2297 c     &  .or. itype(i-1).eq.ntyp1
2298      &                ) cycle
2299         dxi=dc(1,i)
2300         dyi=dc(2,i)
2301         dzi=dc(3,i)
2302         dx_normi=dc_norm(1,i)
2303         dy_normi=dc_norm(2,i)
2304         dz_normi=dc_norm(3,i)
2305         xmedi=c(1,i)+0.5d0*dxi
2306         ymedi=c(2,i)+0.5d0*dyi
2307         zmedi=c(3,i)+0.5d0*dzi
2308         call to_box(xmedi,ymedi,zmedi)
2309         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2310 #ifdef FOURBODY
2311         num_conti=num_cont_hb(i)
2312 #endif
2313 C I TU KURWA
2314         do j=ielstart(i),ielend(i)
2315 C          do j=16,17
2316 C          write (iout,*) i,j
2317 C         if (j.le.1) cycle
2318           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2319 C changes suggested by Ana to avoid out of bounds
2320 c     & .or.((j+2).gt.nres)
2321 c     & .or.((j-1).le.0)
2322 C end of changes by Ana
2323 c     & .or.itype(j+2).eq.ntyp1
2324 c     & .or.itype(j-1).eq.ntyp1
2325      &) cycle
2326           call eelecij(i,j,ees,evdw1,eel_loc)
2327         enddo ! j
2328 #ifdef FOURBODY
2329         num_cont_hb(i)=num_conti
2330 #endif
2331       enddo   ! i
2332 C     enddo   ! zshift
2333 C      enddo   ! yshift
2334 C      enddo   ! xshift
2335
2336 c      write (iout,*) "Number of loop steps in EELEC:",ind
2337 cd      do i=1,nres
2338 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2339 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2340 cd      enddo
2341 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2342 ccc      eel_loc=eel_loc+eello_turn3
2343 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2344       return
2345       end
2346 C-------------------------------------------------------------------------------
2347       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350       include 'DIMENSIONS.ZSCOPT'
2351 #ifdef MPI
2352       include "mpif.h"
2353 #endif
2354       include 'COMMON.CONTROL'
2355       include 'COMMON.IOUNITS'
2356       include 'COMMON.GEO'
2357       include 'COMMON.VAR'
2358       include 'COMMON.LOCAL'
2359       include 'COMMON.CHAIN'
2360       include 'COMMON.DERIV'
2361       include 'COMMON.INTERACT'
2362 #ifdef FOURBODY
2363       include 'COMMON.CONTACTS'
2364       include 'COMMON.CONTMAT'
2365 #endif
2366       include 'COMMON.CORRMAT'
2367       include 'COMMON.TORSION'
2368       include 'COMMON.VECTORS'
2369       include 'COMMON.FFIELD'
2370       include 'COMMON.TIME1'
2371       include 'COMMON.SPLITELE'
2372       include 'COMMON.SHIELD'
2373       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2374      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2375       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2376      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2377      &    gmuij2(4),gmuji2(4)
2378       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2379      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2380      &    num_conti,j1,j2
2381       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
2382      & faclipij2
2383       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
2384 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2385 #ifdef MOMENT
2386       double precision scal_el /1.0d0/
2387 #else
2388       double precision scal_el /0.5d0/
2389 #endif
2390 C 12/13/98
2391 C 13-go grudnia roku pamietnego...
2392       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2393      &                   0.0d0,1.0d0,0.0d0,
2394      &                   0.0d0,0.0d0,1.0d0/
2395        integer xshift,yshift,zshift
2396 c          time00=MPI_Wtime()
2397 cd      write (iout,*) "eelecij",i,j
2398 c          ind=ind+1
2399           iteli=itel(i)
2400           itelj=itel(j)
2401           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2402           aaa=app(iteli,itelj)
2403           bbb=bpp(iteli,itelj)
2404           ael6i=ael6(iteli,itelj)
2405           ael3i=ael3(iteli,itelj)
2406           dxj=dc(1,j)
2407           dyj=dc(2,j)
2408           dzj=dc(3,j)
2409           dx_normj=dc_norm(1,j)
2410           dy_normj=dc_norm(2,j)
2411           dz_normj=dc_norm(3,j)
2412 C          xj=c(1,j)+0.5D0*dxj-xmedi
2413 C          yj=c(2,j)+0.5D0*dyj-ymedi
2414 C          zj=c(3,j)+0.5D0*dzj-zmedi
2415           xj=c(1,j)+0.5D0*dxj
2416           yj=c(2,j)+0.5D0*dyj
2417           zj=c(3,j)+0.5D0*dzj
2418           call to_box(xj,yj,zj)
2419           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2420           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
2421           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
2422           xj=boxshift(xj-xmedi,boxxsize)
2423           yj=boxshift(yj-ymedi,boxysize)
2424           zj=boxshift(zj-zmedi,boxzsize)
2425           rij=xj*xj+yj*yj+zj*zj
2426
2427           sss=sscale(sqrt(rij))
2428           if (sss.eq.0.0d0) return
2429           sssgrad=sscagrad(sqrt(rij))
2430 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2431 c     &       " rlamb",rlamb," sss",sss
2432 c            if (sss.gt.0.0d0) then
2433           rrmij=1.0D0/rij
2434           rij=dsqrt(rij)
2435           rmij=1.0D0/rij
2436           r3ij=rrmij*rmij
2437           r6ij=r3ij*r3ij
2438           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2439           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2440           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2441           fac=cosa-3.0D0*cosb*cosg
2442           ev1=aaa*r6ij*r6ij
2443 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2444           if (j.eq.i+2) ev1=scal_el*ev1
2445           ev2=bbb*r6ij
2446           fac3=ael6i*r6ij
2447           fac4=ael3i*r3ij
2448           evdwij=(ev1+ev2)
2449           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2450           el2=fac4*fac
2451 C MARYSIA
2452 C          eesij=(el1+el2)
2453 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2454           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2455           if (shield_mode.gt.0) then
2456 C          fac_shield(i)=0.4
2457 C          fac_shield(j)=0.6
2458           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2459           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2460           eesij=(el1+el2)
2461           ees=ees+eesij*faclipij2
2462           else
2463           fac_shield(i)=1.0
2464           fac_shield(j)=1.0
2465           eesij=(el1+el2)
2466           ees=ees+eesij*faclipij2
2467           endif
2468           evdw1=evdw1+evdwij*sss*faclipij2
2469 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2470 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2471 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2472 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2473
2474           if (energy_dec) then
2475             write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2476      &'       evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss
2477             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
2478      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
2479      &        faclipij2
2480           endif
2481
2482 C
2483 C Calculate contributions to the Cartesian gradient.
2484 C
2485 #ifdef SPLITELE
2486           facvdw=-6*rrmij*(ev1+evdwij)*sss
2487           facel=-3*rrmij*(el1+eesij)
2488           fac1=fac
2489           erij(1)=xj*rmij
2490           erij(2)=yj*rmij
2491           erij(3)=zj*rmij
2492
2493 *
2494 * Radial derivatives. First process both termini of the fragment (i,j)
2495 *
2496           if (calc_grad) then
2497           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
2498           ggg(1)=aux*xj
2499           ggg(2)=aux*yj
2500           ggg(3)=aux*zj
2501           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2502      &  (shield_mode.gt.0)) then
2503 C          print *,i,j
2504           do ilist=1,ishield_list(i)
2505            iresshield=shield_list(ilist,i)
2506            do k=1,3
2507            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2508      &      *2.0
2509            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2510      &              rlocshield
2511      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2512             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2513 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2514 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2515 C             if (iresshield.gt.i) then
2516 C               do ishi=i+1,iresshield-1
2517 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2518 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2519 C
2520 C              enddo
2521 C             else
2522 C               do ishi=iresshield,i
2523 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2524 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2525 C
2526 C               enddo
2527 C              endif
2528            enddo
2529           enddo
2530           do ilist=1,ishield_list(j)
2531            iresshield=shield_list(ilist,j)
2532            do k=1,3
2533            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2534      &     *2.0
2535            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2536      &              rlocshield
2537      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2538            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2539
2540 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2541 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2542 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2543 C             if (iresshield.gt.j) then
2544 C               do ishi=j+1,iresshield-1
2545 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2546 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2547 C
2548 C               enddo
2549 C            else
2550 C               do ishi=iresshield,j
2551 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2552 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2553 C               enddo
2554 C              endif
2555            enddo
2556           enddo
2557
2558           do k=1,3
2559             gshieldc(k,i)=gshieldc(k,i)+
2560      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2561             gshieldc(k,j)=gshieldc(k,j)+
2562      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2563             gshieldc(k,i-1)=gshieldc(k,i-1)+
2564      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2565             gshieldc(k,j-1)=gshieldc(k,j-1)+
2566      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2567
2568            enddo
2569            endif
2570 c          do k=1,3
2571 c            ghalf=0.5D0*ggg(k)
2572 c            gelc(k,i)=gelc(k,i)+ghalf
2573 c            gelc(k,j)=gelc(k,j)+ghalf
2574 c          enddo
2575 c 9/28/08 AL Gradient compotents will be summed only at the end
2576 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2577           do k=1,3
2578             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2579 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2580             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2581 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2582 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2583 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2584 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2585 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2586           gelc_long(3,j)=gelc_long(3,j)+
2587      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
2588
2589           gelc_long(3,i)=gelc_long(3,i)+
2590      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
2591           enddo
2592 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2593
2594 *
2595 * Loop over residues i+1 thru j-1.
2596 *
2597 cgrad          do k=i+1,j-1
2598 cgrad            do l=1,3
2599 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2600 cgrad            enddo
2601 cgrad          enddo
2602           if (sss.gt.0.0) then
2603           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
2604           ggg(1)=facvdw*xj
2605           ggg(2)=facvdw*yj
2606           ggg(3)=facvdw*zj
2607           else
2608           ggg(1)=0.0
2609           ggg(2)=0.0
2610           ggg(3)=0.0
2611           endif
2612 c          do k=1,3
2613 c            ghalf=0.5D0*ggg(k)
2614 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2615 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2616 c          enddo
2617 c 9/28/08 AL Gradient compotents will be summed only at the end
2618           do k=1,3
2619             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2620             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2621           enddo
2622 !C Lipidic part for scaling weight
2623           gvdwpp(3,j)=gvdwpp(3,j)+
2624      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
2625           gvdwpp(3,i)=gvdwpp(3,i)+
2626      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
2627 *
2628 * Loop over residues i+1 thru j-1.
2629 *
2630 cgrad          do k=i+1,j-1
2631 cgrad            do l=1,3
2632 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2633 cgrad            enddo
2634 cgrad          enddo
2635           endif ! calc_grad
2636 #else
2637 C MARYSIA
2638           facvdw=(ev1+evdwij)*faclipij2
2639           facel=(el1+eesij)
2640           fac1=fac
2641           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2642      &       +(evdwij+eesij)*sssgrad*rrmij
2643           erij(1)=xj*rmij
2644           erij(2)=yj*rmij
2645           erij(3)=zj*rmij
2646 *
2647 * Radial derivatives. First process both termini of the fragment (i,j)
2648 *
2649           if (calc_grad) then
2650           ggg(1)=fac*xj
2651 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2652           ggg(2)=fac*yj
2653 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2654           ggg(3)=fac*zj
2655 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2656 c          do k=1,3
2657 c            ghalf=0.5D0*ggg(k)
2658 c            gelc(k,i)=gelc(k,i)+ghalf
2659 c            gelc(k,j)=gelc(k,j)+ghalf
2660 c          enddo
2661 c 9/28/08 AL Gradient compotents will be summed only at the end
2662           do k=1,3
2663             gelc_long(k,j)=gelc(k,j)+ggg(k)
2664             gelc_long(k,i)=gelc(k,i)-ggg(k)
2665           enddo
2666 *
2667 * Loop over residues i+1 thru j-1.
2668 *
2669 cgrad          do k=i+1,j-1
2670 cgrad            do l=1,3
2671 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2672 cgrad            enddo
2673 cgrad          enddo
2674 c 9/28/08 AL Gradient compotents will be summed only at the end
2675           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2676           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2677           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2678           do k=1,3
2679             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2680             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2681           enddo
2682           gvdwpp(3,j)=gvdwpp(3,j)+
2683      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
2684           gvdwpp(3,i)=gvdwpp(3,i)+
2685      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
2686           endif ! calc_grad
2687 #endif
2688 *
2689 * Angular part
2690 *
2691           if (calc_grad) then
2692           ecosa=2.0D0*fac3*fac1+fac4
2693           fac4=-3.0D0*fac4
2694           fac3=-6.0D0*fac3
2695           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2696           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2697           do k=1,3
2698             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2699             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2700           enddo
2701 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2702 cd   &          (dcosg(k),k=1,3)
2703           do k=1,3
2704             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2705      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
2706           enddo
2707 c          do k=1,3
2708 c            ghalf=0.5D0*ggg(k)
2709 c            gelc(k,i)=gelc(k,i)+ghalf
2710 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2711 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2712 c            gelc(k,j)=gelc(k,j)+ghalf
2713 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2714 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2715 c          enddo
2716 cgrad          do k=i+1,j-1
2717 cgrad            do l=1,3
2718 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2719 cgrad            enddo
2720 cgrad          enddo
2721 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2722           do k=1,3
2723             gelc(k,i)=gelc(k,i)
2724      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2725      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2726      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2727             gelc(k,j)=gelc(k,j)
2728      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2729      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2730      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2731             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2732             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2733           enddo
2734 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2735
2736 C MARYSIA
2737 c          endif !sscale
2738           endif ! calc_grad
2739           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2740      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2741      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2742 C
2743 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2744 C   energy of a peptide unit is assumed in the form of a second-order
2745 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2746 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2747 C   are computed for EVERY pair of non-contiguous peptide groups.
2748 C
2749
2750           if (j.lt.nres-1) then
2751             j1=j+1
2752             j2=j-1
2753           else
2754             j1=j-1
2755             j2=j-2
2756           endif
2757           kkk=0
2758           lll=0
2759           do k=1,2
2760             do l=1,2
2761               kkk=kkk+1
2762               muij(kkk)=mu(k,i)*mu(l,j)
2763 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2764 #ifdef NEWCORR
2765              if (calc_grad) then
2766              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2767 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2768              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2769              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2770 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2771              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2772              endif
2773 #endif
2774             enddo
2775           enddo
2776 #ifdef DEBUG
2777           write (iout,*) 'EELEC: i',i,' j',j
2778           write (iout,*) 'j',j,' j1',j1,' j2',j2
2779           write(iout,*) 'muij',muij
2780           write (iout,*) "uy",uy(:,i)
2781           write (iout,*) "uz",uz(:,j)
2782           write (iout,*) "erij",erij
2783 #endif
2784           ury=scalar(uy(1,i),erij)
2785           urz=scalar(uz(1,i),erij)
2786           vry=scalar(uy(1,j),erij)
2787           vrz=scalar(uz(1,j),erij)
2788           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2789           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2790           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2791           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2792           fac=dsqrt(-ael6i)*r3ij
2793           a22=a22*fac
2794           a23=a23*fac
2795           a32=a32*fac
2796           a33=a33*fac
2797 cd          write (iout,'(4i5,4f10.5)')
2798 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2799 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2800 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2801 cd     &      uy(:,j),uz(:,j)
2802 cd          write (iout,'(4f10.5)')
2803 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2804 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2805 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2806 cd           write (iout,'(9f10.5/)')
2807 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2808 C Derivatives of the elements of A in virtual-bond vectors
2809           if (calc_grad) then
2810           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2811           do k=1,3
2812             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2813             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2814             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2815             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2816             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2817             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2818             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2819             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2820             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2821             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2822             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2823             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2824           enddo
2825 C Compute radial contributions to the gradient
2826           facr=-3.0d0*rrmij
2827           a22der=a22*facr
2828           a23der=a23*facr
2829           a32der=a32*facr
2830           a33der=a33*facr
2831           agg(1,1)=a22der*xj
2832           agg(2,1)=a22der*yj
2833           agg(3,1)=a22der*zj
2834           agg(1,2)=a23der*xj
2835           agg(2,2)=a23der*yj
2836           agg(3,2)=a23der*zj
2837           agg(1,3)=a32der*xj
2838           agg(2,3)=a32der*yj
2839           agg(3,3)=a32der*zj
2840           agg(1,4)=a33der*xj
2841           agg(2,4)=a33der*yj
2842           agg(3,4)=a33der*zj
2843 C Add the contributions coming from er
2844           fac3=-3.0d0*fac
2845           do k=1,3
2846             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2847             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2848             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2849             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2850           enddo
2851           do k=1,3
2852 C Derivatives in DC(i)
2853 cgrad            ghalf1=0.5d0*agg(k,1)
2854 cgrad            ghalf2=0.5d0*agg(k,2)
2855 cgrad            ghalf3=0.5d0*agg(k,3)
2856 cgrad            ghalf4=0.5d0*agg(k,4)
2857             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2858      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2859             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2860      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2861             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2862      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2863             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2864      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2865 C Derivatives in DC(i+1)
2866             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2867      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2868             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2869      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2870             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2871      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2872             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2873      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2874 C Derivatives in DC(j)
2875             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2876      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2877             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2878      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2879             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2880      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2881             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2882      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2883 C Derivatives in DC(j+1) or DC(nres-1)
2884             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2885      &      -3.0d0*vryg(k,3)*ury)
2886             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2887      &      -3.0d0*vrzg(k,3)*ury)
2888             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2889      &      -3.0d0*vryg(k,3)*urz)
2890             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2891      &      -3.0d0*vrzg(k,3)*urz)
2892 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2893 cgrad              do l=1,4
2894 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2895 cgrad              enddo
2896 cgrad            endif
2897           enddo
2898           endif ! calc_grad
2899           acipa(1,1)=a22
2900           acipa(1,2)=a23
2901           acipa(2,1)=a32
2902           acipa(2,2)=a33
2903           a22=-a22
2904           a23=-a23
2905           if (calc_grad) then
2906           do l=1,2
2907             do k=1,3
2908               agg(k,l)=-agg(k,l)
2909               aggi(k,l)=-aggi(k,l)
2910               aggi1(k,l)=-aggi1(k,l)
2911               aggj(k,l)=-aggj(k,l)
2912               aggj1(k,l)=-aggj1(k,l)
2913             enddo
2914           enddo
2915           endif ! calc_grad
2916           if (j.lt.nres-1) then
2917             a22=-a22
2918             a32=-a32
2919             do l=1,3,2
2920               do k=1,3
2921                 agg(k,l)=-agg(k,l)
2922                 aggi(k,l)=-aggi(k,l)
2923                 aggi1(k,l)=-aggi1(k,l)
2924                 aggj(k,l)=-aggj(k,l)
2925                 aggj1(k,l)=-aggj1(k,l)
2926               enddo
2927             enddo
2928           else
2929             a22=-a22
2930             a23=-a23
2931             a32=-a32
2932             a33=-a33
2933             do l=1,4
2934               do k=1,3
2935                 agg(k,l)=-agg(k,l)
2936                 aggi(k,l)=-aggi(k,l)
2937                 aggi1(k,l)=-aggi1(k,l)
2938                 aggj(k,l)=-aggj(k,l)
2939                 aggj1(k,l)=-aggj1(k,l)
2940               enddo
2941             enddo
2942           endif
2943           ENDIF ! WCORR
2944           IF (wel_loc.gt.0.0d0) THEN
2945 C Contribution to the local-electrostatic energy coming from the i-j pair
2946           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2947      &     +a33*muij(4)
2948 #ifdef DEBUG
2949           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2950      &     " a33",a33
2951           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2952      &     " wel_loc",wel_loc
2953 #endif
2954           if (shield_mode.eq.0) then
2955            fac_shield(i)=1.0
2956            fac_shield(j)=1.0
2957 C          else
2958 C           fac_shield(i)=0.4
2959 C           fac_shield(j)=0.6
2960           endif
2961           eel_loc_ij=eel_loc_ij
2962      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
2963           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2964      &            'eelloc',i,j,eel_loc_ij
2965 c           if (eel_loc_ij.ne.0)
2966 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2967 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2968
2969           eel_loc=eel_loc+eel_loc_ij
2970 C Now derivative over eel_loc
2971           if (calc_grad) then
2972           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2973      &  (shield_mode.gt.0)) then
2974 C          print *,i,j
2975
2976           do ilist=1,ishield_list(i)
2977            iresshield=shield_list(ilist,i)
2978            do k=1,3
2979            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2980      &                                          /fac_shield(i)
2981 C     &      *2.0
2982            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2983      &              rlocshield
2984      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2985             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2986      &      +rlocshield
2987            enddo
2988           enddo
2989           do ilist=1,ishield_list(j)
2990            iresshield=shield_list(ilist,j)
2991            do k=1,3
2992            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2993      &                                       /fac_shield(j)
2994 C     &     *2.0
2995            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2996      &              rlocshield
2997      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2998            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2999      &             +rlocshield
3000
3001            enddo
3002           enddo
3003
3004           do k=1,3
3005             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3006      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3007             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3008      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3009             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3010      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3011             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3012      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3013            enddo
3014            endif
3015
3016
3017 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3018 c     &                     ' eel_loc_ij',eel_loc_ij
3019 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3020 C Calculate patrial derivative for theta angle
3021 #ifdef NEWCORR
3022          geel_loc_ij=(a22*gmuij1(1)
3023      &     +a23*gmuij1(2)
3024      &     +a32*gmuij1(3)
3025      &     +a33*gmuij1(4))
3026      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3027 c         write(iout,*) "derivative over thatai"
3028 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3029 c     &   a33*gmuij1(4)
3030          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3031      &      geel_loc_ij*wel_loc
3032 c         write(iout,*) "derivative over thatai-1"
3033 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3034 c     &   a33*gmuij2(4)
3035          geel_loc_ij=
3036      &     a22*gmuij2(1)
3037      &     +a23*gmuij2(2)
3038      &     +a32*gmuij2(3)
3039      &     +a33*gmuij2(4)
3040          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3041      &      geel_loc_ij*wel_loc
3042      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3043
3044 c  Derivative over j residue
3045          geel_loc_ji=a22*gmuji1(1)
3046      &     +a23*gmuji1(2)
3047      &     +a32*gmuji1(3)
3048      &     +a33*gmuji1(4)
3049 c         write(iout,*) "derivative over thataj"
3050 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3051 c     &   a33*gmuji1(4)
3052
3053         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3054      &      geel_loc_ji*wel_loc
3055      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3056
3057          geel_loc_ji=
3058      &     +a22*gmuji2(1)
3059      &     +a23*gmuji2(2)
3060      &     +a32*gmuji2(3)
3061      &     +a33*gmuji2(4)
3062 c         write(iout,*) "derivative over thataj-1"
3063 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3064 c     &   a33*gmuji2(4)
3065          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3066      &      geel_loc_ji*wel_loc
3067      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3068 #endif
3069 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3070
3071 C Partial derivatives in virtual-bond dihedral angles gamma
3072           if (i.gt.1)
3073      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3074      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3075      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3076      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3077
3078           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3079      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3080      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3081      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3082 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3083           aux=eel_loc_ij/sss*sssgrad*rmij
3084           ggg(1)=aux*xj
3085           ggg(2)=aux*yj
3086           ggg(3)=aux*zj
3087           do l=1,3
3088             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3089      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3090      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3091             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3092             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3093 cgrad            ghalf=0.5d0*ggg(l)
3094 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3095 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3096           enddo
3097           gel_loc_long(3,j)=gel_loc_long(3,j)+
3098      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
3099
3100           gel_loc_long(3,i)=gel_loc_long(3,i)+
3101      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
3102 cgrad          do k=i+1,j2
3103 cgrad            do l=1,3
3104 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3105 cgrad            enddo
3106 cgrad          enddo
3107 C Remaining derivatives of eello
3108           do l=1,3
3109             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3110      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3111      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3112
3113             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3114      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3115      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3116
3117             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3118      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3119      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3120
3121             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3122      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3123      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3124
3125           enddo
3126           endif ! calc_grad
3127           ENDIF
3128
3129
3130 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3131 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3132 #ifdef FOURBODY
3133           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3134      &       .and. num_conti.le.maxconts) then
3135 c            write (iout,*) i,j," entered corr"
3136 C
3137 C Calculate the contact function. The ith column of the array JCONT will
3138 C contain the numbers of atoms that make contacts with the atom I (of numbers
3139 C greater than I). The arrays FACONT and GACONT will contain the values of
3140 C the contact function and its derivative.
3141 c           r0ij=1.02D0*rpp(iteli,itelj)
3142 c           r0ij=1.11D0*rpp(iteli,itelj)
3143             r0ij=2.20D0*rpp(iteli,itelj)
3144 c           r0ij=1.55D0*rpp(iteli,itelj)
3145             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3146             if (fcont.gt.0.0D0) then
3147               num_conti=num_conti+1
3148               if (num_conti.gt.maxconts) then
3149                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3150      &                         ' will skip next contacts for this conf.'
3151               else
3152                 jcont_hb(num_conti,i)=j
3153 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3154 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3155                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3156      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3157 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3158 C  terms.
3159                 d_cont(num_conti,i)=rij
3160 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3161 C     --- Electrostatic-interaction matrix ---
3162                 a_chuj(1,1,num_conti,i)=a22
3163                 a_chuj(1,2,num_conti,i)=a23
3164                 a_chuj(2,1,num_conti,i)=a32
3165                 a_chuj(2,2,num_conti,i)=a33
3166 C     --- Gradient of rij
3167                 if (calc_grad) then
3168                 do kkk=1,3
3169                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3170                 enddo
3171                 kkll=0
3172                 do k=1,2
3173                   do l=1,2
3174                     kkll=kkll+1
3175                     do m=1,3
3176                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3177                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3178                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3179                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3180                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3181                     enddo
3182                   enddo
3183                 enddo
3184                 endif ! calc_grad
3185                 ENDIF
3186                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3187 C Calculate contact energies
3188                 cosa4=4.0D0*cosa
3189                 wij=cosa-3.0D0*cosb*cosg
3190                 cosbg1=cosb+cosg
3191                 cosbg2=cosb-cosg
3192 c               fac3=dsqrt(-ael6i)/r0ij**3
3193                 fac3=dsqrt(-ael6i)*r3ij
3194 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3195                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3196                 if (ees0tmp.gt.0) then
3197                   ees0pij=dsqrt(ees0tmp)
3198                 else
3199                   ees0pij=0
3200                 endif
3201 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3202                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3203                 if (ees0tmp.gt.0) then
3204                   ees0mij=dsqrt(ees0tmp)
3205                 else
3206                   ees0mij=0
3207                 endif
3208 c               ees0mij=0.0D0
3209                 if (shield_mode.eq.0) then
3210                 fac_shield(i)=1.0d0
3211                 fac_shield(j)=1.0d0
3212                 else
3213                 ees0plist(num_conti,i)=j
3214 C                fac_shield(i)=0.4d0
3215 C                fac_shield(j)=0.6d0
3216                 endif
3217                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3218      &          *fac_shield(i)*fac_shield(j)
3219                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3220      &          *fac_shield(i)*fac_shield(j)
3221 C Diagnostics. Comment out or remove after debugging!
3222 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3223 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3224 c               ees0m(num_conti,i)=0.0D0
3225 C End diagnostics.
3226 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3227 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3228 C Angular derivatives of the contact function
3229
3230                 ees0pij1=fac3/ees0pij
3231                 ees0mij1=fac3/ees0mij
3232                 fac3p=-3.0D0*fac3*rrmij
3233                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3234                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3235 c               ees0mij1=0.0D0
3236                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3237                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3238                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3239                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3240                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3241                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3242                 ecosap=ecosa1+ecosa2
3243                 ecosbp=ecosb1+ecosb2
3244                 ecosgp=ecosg1+ecosg2
3245                 ecosam=ecosa1-ecosa2
3246                 ecosbm=ecosb1-ecosb2
3247                 ecosgm=ecosg1-ecosg2
3248 C Diagnostics
3249 c               ecosap=ecosa1
3250 c               ecosbp=ecosb1
3251 c               ecosgp=ecosg1
3252 c               ecosam=0.0D0
3253 c               ecosbm=0.0D0
3254 c               ecosgm=0.0D0
3255 C End diagnostics
3256                 facont_hb(num_conti,i)=fcont
3257
3258                 if (calc_grad) then
3259                 fprimcont=fprimcont/rij
3260 cd              facont_hb(num_conti,i)=1.0D0
3261 C Following line is for diagnostics.
3262 cd              fprimcont=0.0D0
3263                 do k=1,3
3264                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3265                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3266                 enddo
3267                 do k=1,3
3268                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3269                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3270                 enddo
3271                 gggp(1)=gggp(1)+ees0pijp*xj
3272      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3273                 gggp(2)=gggp(2)+ees0pijp*yj
3274      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3275                 gggp(3)=gggp(3)+ees0pijp*zj
3276      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3277                 gggm(1)=gggm(1)+ees0mijp*xj
3278      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3279                 gggm(2)=gggm(2)+ees0mijp*yj
3280      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3281                 gggm(3)=gggm(3)+ees0mijp*zj
3282      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3283 C Derivatives due to the contact function
3284                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3285                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3286                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3287                 do k=1,3
3288 c
3289 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3290 c          following the change of gradient-summation algorithm.
3291 c
3292 cgrad                  ghalfp=0.5D0*gggp(k)
3293 cgrad                  ghalfm=0.5D0*gggm(k)
3294                   gacontp_hb1(k,num_conti,i)=!ghalfp
3295      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297      &          *fac_shield(i)*fac_shield(j)*sss
3298
3299                   gacontp_hb2(k,num_conti,i)=!ghalfp
3300      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3301      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3302      &          *fac_shield(i)*fac_shield(j)*sss
3303
3304                   gacontp_hb3(k,num_conti,i)=gggp(k)
3305      &          *fac_shield(i)*fac_shield(j)*sss
3306
3307                   gacontm_hb1(k,num_conti,i)=!ghalfm
3308      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3309      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3310      &          *fac_shield(i)*fac_shield(j)*sss
3311
3312                   gacontm_hb2(k,num_conti,i)=!ghalfm
3313      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3314      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3315      &          *fac_shield(i)*fac_shield(j)*sss
3316
3317                   gacontm_hb3(k,num_conti,i)=gggm(k)
3318      &          *fac_shield(i)*fac_shield(j)*sss
3319
3320                 enddo
3321 C Diagnostics. Comment out or remove after debugging!
3322 cdiag           do k=1,3
3323 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3324 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3325 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3326 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3327 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3328 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3329 cdiag           enddo
3330
3331                  endif ! calc_grad
3332
3333               ENDIF ! wcorr
3334               endif  ! num_conti.le.maxconts
3335             endif  ! fcont.gt.0
3336           endif    ! j.gt.i+1
3337 #endif
3338           if (calc_grad) then
3339           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3340             do k=1,4
3341               do l=1,3
3342                 ghalf=0.5d0*agg(l,k)
3343                 aggi(l,k)=aggi(l,k)+ghalf
3344                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3345                 aggj(l,k)=aggj(l,k)+ghalf
3346               enddo
3347             enddo
3348             if (j.eq.nres-1 .and. i.lt.j-2) then
3349               do k=1,4
3350                 do l=1,3
3351                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3352                 enddo
3353               enddo
3354             endif
3355           endif
3356           endif ! calc_grad
3357 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3358       return
3359       end
3360 C-----------------------------------------------------------------------------
3361       subroutine eturn3(i,eello_turn3)
3362 C Third- and fourth-order contributions from turns
3363       implicit real*8 (a-h,o-z)
3364       include 'DIMENSIONS'
3365       include 'DIMENSIONS.ZSCOPT'
3366       include 'COMMON.IOUNITS'
3367       include 'COMMON.GEO'
3368       include 'COMMON.VAR'
3369       include 'COMMON.LOCAL'
3370       include 'COMMON.CHAIN'
3371       include 'COMMON.DERIV'
3372       include 'COMMON.INTERACT'
3373       include 'COMMON.CONTACTS'
3374       include 'COMMON.TORSION'
3375       include 'COMMON.VECTORS'
3376       include 'COMMON.FFIELD'
3377       include 'COMMON.CONTROL'
3378       include 'COMMON.SHIELD'
3379       include 'COMMON.CORRMAT'
3380       dimension ggg(3)
3381       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3382      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3383      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3384      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3385      &  auxgmat2(2,2),auxgmatt2(2,2)
3386       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3387      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3388       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3389      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3390      &    num_conti,j1,j2
3391       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3392       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3393       j=i+2
3394 c      write (iout,*) "eturn3",i,j,j1,j2
3395       a_temp(1,1)=a22
3396       a_temp(1,2)=a23
3397       a_temp(2,1)=a32
3398       a_temp(2,2)=a33
3399 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3400 C
3401 C               Third-order contributions
3402 C
3403 C                 (i+2)o----(i+3)
3404 C                      | |
3405 C                      | |
3406 C                 (i+1)o----i
3407 C
3408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3409 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3410         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3411 c auxalary matices for theta gradient
3412 c auxalary matrix for i+1 and constant i+2
3413         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3414 c auxalary matrix for i+2 and constant i+1
3415         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3416         call transpose2(auxmat(1,1),auxmat1(1,1))
3417         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3418         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3419         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3420         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3421         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3422         if (shield_mode.eq.0) then
3423         fac_shield(i)=1.0
3424         fac_shield(j)=1.0
3425 C        else
3426 C        fac_shield(i)=0.4
3427 C        fac_shield(j)=0.6
3428         endif
3429         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3430      &  *fac_shield(i)*fac_shield(j)*faclipij
3431         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3432      &  *fac_shield(i)*fac_shield(j)
3433         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3434      &    eello_t3
3435         if (calc_grad) then
3436 C#ifdef NEWCORR
3437 C Derivatives in theta
3438         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3439      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3440      &   *fac_shield(i)*fac_shield(j)*faclipij
3441         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3442      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3443      &   *fac_shield(i)*fac_shield(j)*faclipij
3444 C#endif
3445
3446 C Derivatives in shield mode
3447           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3448      &  (shield_mode.gt.0)) then
3449 C          print *,i,j
3450
3451           do ilist=1,ishield_list(i)
3452            iresshield=shield_list(ilist,i)
3453            do k=1,3
3454            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3455 C     &      *2.0
3456            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3457      &              rlocshield
3458      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3459             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3460      &      +rlocshield
3461            enddo
3462           enddo
3463           do ilist=1,ishield_list(j)
3464            iresshield=shield_list(ilist,j)
3465            do k=1,3
3466            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3467 C     &     *2.0
3468            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3469      &              rlocshield
3470      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3471            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3472      &             +rlocshield
3473
3474            enddo
3475           enddo
3476
3477           do k=1,3
3478             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3479      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3480             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3481      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3482             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3483      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3484             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3485      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3486            enddo
3487            endif
3488
3489 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3490 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3491 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3492 cd     &    ' eello_turn3_num',4*eello_turn3_num
3493 C Derivatives in gamma(i)
3494         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3495         call transpose2(auxmat2(1,1),auxmat3(1,1))
3496         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3497         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3498      &   *fac_shield(i)*fac_shield(j)*faclipij
3499 C Derivatives in gamma(i+1)
3500         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3501         call transpose2(auxmat2(1,1),auxmat3(1,1))
3502         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3503         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3504      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3505      &   *fac_shield(i)*fac_shield(j)*faclipij
3506 C Cartesian derivatives
3507         do l=1,3
3508 c            ghalf1=0.5d0*agg(l,1)
3509 c            ghalf2=0.5d0*agg(l,2)
3510 c            ghalf3=0.5d0*agg(l,3)
3511 c            ghalf4=0.5d0*agg(l,4)
3512           a_temp(1,1)=aggi(l,1)!+ghalf1
3513           a_temp(1,2)=aggi(l,2)!+ghalf2
3514           a_temp(2,1)=aggi(l,3)!+ghalf3
3515           a_temp(2,2)=aggi(l,4)!+ghalf4
3516           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3517           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3518      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3519      &   *fac_shield(i)*fac_shield(j)*faclipij
3520
3521           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3522           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3523           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3524           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3525           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3526           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3527      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3528      &   *fac_shield(i)*fac_shield(j)*faclipij
3529           a_temp(1,1)=aggj(l,1)!+ghalf1
3530           a_temp(1,2)=aggj(l,2)!+ghalf2
3531           a_temp(2,1)=aggj(l,3)!+ghalf3
3532           a_temp(2,2)=aggj(l,4)!+ghalf4
3533           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3534           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3535      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3536      &   *fac_shield(i)*fac_shield(j)*faclipij
3537           a_temp(1,1)=aggj1(l,1)
3538           a_temp(1,2)=aggj1(l,2)
3539           a_temp(2,1)=aggj1(l,3)
3540           a_temp(2,2)=aggj1(l,4)
3541           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3542           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3543      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3544      &   *fac_shield(i)*fac_shield(j)*faclipij
3545         enddo
3546
3547         endif ! calc_grad
3548
3549       return
3550       end
3551 C-------------------------------------------------------------------------------
3552       subroutine eturn4(i,eello_turn4)
3553 C Third- and fourth-order contributions from turns
3554       implicit real*8 (a-h,o-z)
3555       include 'DIMENSIONS'
3556       include 'DIMENSIONS.ZSCOPT'
3557       include 'COMMON.IOUNITS'
3558       include 'COMMON.GEO'
3559       include 'COMMON.VAR'
3560       include 'COMMON.LOCAL'
3561       include 'COMMON.CHAIN'
3562       include 'COMMON.DERIV'
3563       include 'COMMON.INTERACT'
3564       include 'COMMON.CONTACTS'
3565       include 'COMMON.TORSION'
3566       include 'COMMON.VECTORS'
3567       include 'COMMON.FFIELD'
3568       include 'COMMON.CONTROL'
3569       include 'COMMON.SHIELD'
3570       include 'COMMON.CORRMAT'
3571       dimension ggg(3)
3572       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3573      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3574      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3575      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3576      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3577      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3578      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3579       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3580      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3581       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3582      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3583      &    num_conti,j1,j2
3584       j=i+3
3585 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3586 C
3587 C               Fourth-order contributions
3588 C
3589 C                 (i+3)o----(i+4)
3590 C                     /  |
3591 C               (i+2)o   |
3592 C                     \  |
3593 C                 (i+1)o----i
3594 C
3595 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3596 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3597 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3598 c        write(iout,*)"WCHODZE W PROGRAM"
3599         a_temp(1,1)=a22
3600         a_temp(1,2)=a23
3601         a_temp(2,1)=a32
3602         a_temp(2,2)=a33
3603         iti1=itype2loc(itype(i+1))
3604         iti2=itype2loc(itype(i+2))
3605         iti3=itype2loc(itype(i+3))
3606 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3607         call transpose2(EUg(1,1,i+1),e1t(1,1))
3608         call transpose2(Eug(1,1,i+2),e2t(1,1))
3609         call transpose2(Eug(1,1,i+3),e3t(1,1))
3610 C Ematrix derivative in theta
3611         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3612         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3613         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3614         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3615 c       eta1 in derivative theta
3616         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3617         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3618 c       auxgvec is derivative of Ub2 so i+3 theta
3619         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3620 c       auxalary matrix of E i+1
3621         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3622 c        s1=0.0
3623 c        gs1=0.0
3624         s1=scalar2(b1(1,i+2),auxvec(1))
3625 c derivative of theta i+2 with constant i+3
3626         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3627 c derivative of theta i+2 with constant i+2
3628         gs32=scalar2(b1(1,i+2),auxgvec(1))
3629 c derivative of E matix in theta of i+1
3630         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3631
3632         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3633 c       ea31 in derivative theta
3634         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3635         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3636 c auxilary matrix auxgvec of Ub2 with constant E matirx
3637         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3638 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3639         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3640
3641 c        s2=0.0
3642 c        gs2=0.0
3643         s2=scalar2(b1(1,i+1),auxvec(1))
3644 c derivative of theta i+1 with constant i+3
3645         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3646 c derivative of theta i+2 with constant i+1
3647         gs21=scalar2(b1(1,i+1),auxgvec(1))
3648 c derivative of theta i+3 with constant i+1
3649         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3650 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3651 c     &  gtb1(1,i+1)
3652         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3653 c two derivatives over diffetent matrices
3654 c gtae3e2 is derivative over i+3
3655         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3656 c ae3gte2 is derivative over i+2
3657         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3658         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3659 c three possible derivative over theta E matices
3660 c i+1
3661         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3662 c i+2
3663         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3664 c i+3
3665         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3666         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3667
3668         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3669         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3670         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3671         if (shield_mode.eq.0) then
3672         fac_shield(i)=1.0
3673         fac_shield(j)=1.0
3674 C        else
3675 C        fac_shield(i)=0.6
3676 C        fac_shield(j)=0.4
3677         endif
3678         eello_turn4=eello_turn4-(s1+s2+s3)
3679      &  *fac_shield(i)*fac_shield(j)*faclipij
3680         eello_t4=-(s1+s2+s3)
3681      &  *fac_shield(i)*fac_shield(j)
3682 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3683         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3684      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3685 C Now derivative over shield:
3686           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3687      &  (shield_mode.gt.0)) then
3688 C          print *,i,j
3689
3690           do ilist=1,ishield_list(i)
3691            iresshield=shield_list(ilist,i)
3692            do k=1,3
3693            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3694 C     &      *2.0
3695            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3696      &              rlocshield
3697      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3698             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3699      &      +rlocshield
3700            enddo
3701           enddo
3702           do ilist=1,ishield_list(j)
3703            iresshield=shield_list(ilist,j)
3704            do k=1,3
3705            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3706 C     &     *2.0
3707            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3708      &              rlocshield
3709      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3710            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3711      &             +rlocshield
3712
3713            enddo
3714           enddo
3715
3716           do k=1,3
3717             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3718      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3719             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3720      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3721             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3722      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3723             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3724      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3725            enddo
3726            endif
3727 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3728 cd     &    ' eello_turn4_num',8*eello_turn4_num
3729 #ifdef NEWCORR
3730         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3731      &                  -(gs13+gsE13+gsEE1)*wturn4
3732      &  *fac_shield(i)*fac_shield(j)
3733         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3734      &                    -(gs23+gs21+gsEE2)*wturn4
3735      &  *fac_shield(i)*fac_shield(j)
3736
3737         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3738      &                    -(gs32+gsE31+gsEE3)*wturn4
3739      &  *fac_shield(i)*fac_shield(j)
3740
3741 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3742 c     &   gs2
3743 #endif
3744         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3745      &      'eturn4',i,j,-(s1+s2+s3)
3746 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3747 c     &    ' eello_turn4_num',8*eello_turn4_num
3748 C Derivatives in gamma(i)
3749         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3750         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3751         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3752         s1=scalar2(b1(1,i+2),auxvec(1))
3753         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3754         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3755         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3756      &  *fac_shield(i)*fac_shield(j)*faclipij
3757 C Derivatives in gamma(i+1)
3758         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3759         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3760         s2=scalar2(b1(1,i+1),auxvec(1))
3761         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3762         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3763         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3764         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3765      &  *fac_shield(i)*fac_shield(j)*faclipij
3766 C Derivatives in gamma(i+2)
3767         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3768         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3769         s1=scalar2(b1(1,i+2),auxvec(1))
3770         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3771         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3772         s2=scalar2(b1(1,i+1),auxvec(1))
3773         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3774         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3775         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3776         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3777      &  *fac_shield(i)*fac_shield(j)*faclipij
3778         if (calc_grad) then
3779 C Cartesian derivatives
3780 C Derivatives of this turn contributions in DC(i+2)
3781         if (j.lt.nres-1) then
3782           do l=1,3
3783             a_temp(1,1)=agg(l,1)
3784             a_temp(1,2)=agg(l,2)
3785             a_temp(2,1)=agg(l,3)
3786             a_temp(2,2)=agg(l,4)
3787             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3788             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3789             s1=scalar2(b1(1,i+2),auxvec(1))
3790             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3791             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3792             s2=scalar2(b1(1,i+1),auxvec(1))
3793             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3794             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3795             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3796             ggg(l)=-(s1+s2+s3)
3797             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3798      &  *fac_shield(i)*fac_shield(j)*faclipij
3799           enddo
3800         endif
3801 C Remaining derivatives of this turn contribution
3802         do l=1,3
3803           a_temp(1,1)=aggi(l,1)
3804           a_temp(1,2)=aggi(l,2)
3805           a_temp(2,1)=aggi(l,3)
3806           a_temp(2,2)=aggi(l,4)
3807           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3808           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3809           s1=scalar2(b1(1,i+2),auxvec(1))
3810           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3811           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3812           s2=scalar2(b1(1,i+1),auxvec(1))
3813           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3814           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3815           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3816           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3817      &  *fac_shield(i)*fac_shield(j)*faclipij
3818           a_temp(1,1)=aggi1(l,1)
3819           a_temp(1,2)=aggi1(l,2)
3820           a_temp(2,1)=aggi1(l,3)
3821           a_temp(2,2)=aggi1(l,4)
3822           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3823           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3824           s1=scalar2(b1(1,i+2),auxvec(1))
3825           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3826           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3827           s2=scalar2(b1(1,i+1),auxvec(1))
3828           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3829           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3830           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3831           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3832      &  *fac_shield(i)*fac_shield(j)*faclipij
3833           a_temp(1,1)=aggj(l,1)
3834           a_temp(1,2)=aggj(l,2)
3835           a_temp(2,1)=aggj(l,3)
3836           a_temp(2,2)=aggj(l,4)
3837           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3838           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3839           s1=scalar2(b1(1,i+2),auxvec(1))
3840           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3841           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3842           s2=scalar2(b1(1,i+1),auxvec(1))
3843           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3844           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3845           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3846           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3847      &  *fac_shield(i)*fac_shield(j)*faclipij
3848           a_temp(1,1)=aggj1(l,1)
3849           a_temp(1,2)=aggj1(l,2)
3850           a_temp(2,1)=aggj1(l,3)
3851           a_temp(2,2)=aggj1(l,4)
3852           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3853           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3854           s1=scalar2(b1(1,i+2),auxvec(1))
3855           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3856           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3857           s2=scalar2(b1(1,i+1),auxvec(1))
3858           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3859           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3860           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3861 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3862           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3863      &  *fac_shield(i)*fac_shield(j)*faclipij
3864         enddo
3865
3866         endif ! calc_grad
3867
3868       return
3869       end
3870 C-----------------------------------------------------------------------------
3871       subroutine vecpr(u,v,w)
3872       implicit real*8(a-h,o-z)
3873       dimension u(3),v(3),w(3)
3874       w(1)=u(2)*v(3)-u(3)*v(2)
3875       w(2)=-u(1)*v(3)+u(3)*v(1)
3876       w(3)=u(1)*v(2)-u(2)*v(1)
3877       return
3878       end
3879 C-----------------------------------------------------------------------------
3880       subroutine unormderiv(u,ugrad,unorm,ungrad)
3881 C This subroutine computes the derivatives of a normalized vector u, given
3882 C the derivatives computed without normalization conditions, ugrad. Returns
3883 C ungrad.
3884       implicit none
3885       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3886       double precision vec(3)
3887       double precision scalar
3888       integer i,j
3889 c      write (2,*) 'ugrad',ugrad
3890 c      write (2,*) 'u',u
3891       do i=1,3
3892         vec(i)=scalar(ugrad(1,i),u(1))
3893       enddo
3894 c      write (2,*) 'vec',vec
3895       do i=1,3
3896         do j=1,3
3897           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3898         enddo
3899       enddo
3900 c      write (2,*) 'ungrad',ungrad
3901       return
3902       end
3903 C-----------------------------------------------------------------------------
3904       subroutine escp(evdw2,evdw2_14)
3905 C
3906 C This subroutine calculates the excluded-volume interaction energy between
3907 C peptide-group centers and side chains and its gradient in virtual-bond and
3908 C side-chain vectors.
3909 C
3910       implicit real*8 (a-h,o-z)
3911       include 'DIMENSIONS'
3912       include 'DIMENSIONS.ZSCOPT'
3913       include 'COMMON.CONTROL'
3914       include 'COMMON.GEO'
3915       include 'COMMON.VAR'
3916       include 'COMMON.LOCAL'
3917       include 'COMMON.CHAIN'
3918       include 'COMMON.DERIV'
3919       include 'COMMON.INTERACT'
3920       include 'COMMON.FFIELD'
3921       include 'COMMON.IOUNITS'
3922       dimension ggg(3)
3923       evdw2=0.0D0
3924       evdw2_14=0.0d0
3925 cd    print '(a)','Enter ESCP'
3926 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3927 c     &  ' scal14',scal14
3928       do i=iatscp_s,iatscp_e
3929         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3930         iteli=itel(i)
3931 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3932 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3933         if (iteli.eq.0) goto 1225
3934         xi=0.5D0*(c(1,i)+c(1,i+1))
3935         yi=0.5D0*(c(2,i)+c(2,i+1))
3936         zi=0.5D0*(c(3,i)+c(3,i+1))
3937         call to_box(xi,yi,zi)
3938         do iint=1,nscp_gr(i)
3939
3940         do j=iscpstart(i,iint),iscpend(i,iint)
3941           itypj=iabs(itype(j))
3942           if (itypj.eq.ntyp1) cycle
3943 C Uncomment following three lines for SC-p interactions
3944 c         xj=c(1,nres+j)-xi
3945 c         yj=c(2,nres+j)-yi
3946 c         zj=c(3,nres+j)-zi
3947 C Uncomment following three lines for Ca-p interactions
3948           xj=c(1,j)
3949           yj=c(2,j)
3950           zj=c(3,j)
3951 C returning the jth atom to box
3952           call to_box(xj,yj,zj)
3953           xj=boxshift(xj-xi,boxxsize)
3954           yj=boxshift(yj-yi,boxysize)
3955           zj=boxshift(zj-zi,boxzsize)
3956           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3957 C sss is scaling function for smoothing the cutoff gradient otherwise
3958 C the gradient would not be continuouse
3959           sss=sscale(1.0d0/(dsqrt(rrij)))
3960           if (sss.le.0.0d0) cycle
3961           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3962           fac=rrij**expon2
3963           e1=fac*fac*aad(itypj,iteli)
3964           e2=fac*bad(itypj,iteli)
3965           if (iabs(j-i) .le. 2) then
3966             e1=scal14*e1
3967             e2=scal14*e2
3968             evdw2_14=evdw2_14+(e1+e2)*sss
3969           endif
3970           evdwij=e1+e2
3971 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3972 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3973 c     &       bad(itypj,iteli)
3974           evdw2=evdw2+evdwij*sss
3975           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3976      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3977      &       bad(itypj,iteli)
3978
3979           if (calc_grad) then
3980 C
3981 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3982 C
3983           fac=-(evdwij+e1)*rrij*sss
3984           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3985           ggg(1)=xj*fac
3986           ggg(2)=yj*fac
3987           ggg(3)=zj*fac
3988           if (j.lt.i) then
3989 cd          write (iout,*) 'j<i'
3990 C Uncomment following three lines for SC-p interactions
3991 c           do k=1,3
3992 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3993 c           enddo
3994           else
3995 cd          write (iout,*) 'j>i'
3996             do k=1,3
3997               ggg(k)=-ggg(k)
3998 C Uncomment following line for SC-p interactions
3999 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4000             enddo
4001           endif
4002           do k=1,3
4003             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4004           enddo
4005           kstart=min0(i+1,j)
4006           kend=max0(i-1,j-1)
4007 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4008 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4009           do k=kstart,kend
4010             do l=1,3
4011               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4012             enddo
4013           enddo
4014           endif ! calc_grad
4015         enddo
4016         enddo ! iint
4017  1225   continue
4018       enddo ! i
4019       do i=1,nct
4020         do j=1,3
4021           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4022           gradx_scp(j,i)=expon*gradx_scp(j,i)
4023         enddo
4024       enddo
4025 C******************************************************************************
4026 C
4027 C                              N O T E !!!
4028 C
4029 C To save time the factor EXPON has been extracted from ALL components
4030 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4031 C use!
4032 C
4033 C******************************************************************************
4034       return
4035       end
4036 C--------------------------------------------------------------------------
4037       subroutine edis(ehpb)
4038 C
4039 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4040 C
4041       implicit real*8 (a-h,o-z)
4042       include 'DIMENSIONS'
4043       include 'DIMENSIONS.ZSCOPT'
4044       include 'COMMON.SBRIDGE'
4045       include 'COMMON.CHAIN'
4046       include 'COMMON.DERIV'
4047       include 'COMMON.VAR'
4048       include 'COMMON.INTERACT'
4049       include 'COMMON.CONTROL'
4050       include 'COMMON.IOUNITS'
4051       dimension ggg(3),ggg_peak(3,1000)
4052       ehpb=0.0D0
4053       do i=1,3
4054        ggg(i)=0.0d0
4055       enddo
4056 c 8/21/18 AL: added explicit restraints on reference coords
4057 c      write (iout,*) "restr_on_coord",restr_on_coord
4058       if (restr_on_coord) then
4059
4060       do i=nnt,nct
4061         ecoor=0.0d0
4062         if (itype(i).eq.ntyp1) cycle
4063         do j=1,3
4064           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4065           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4066         enddo
4067         if (itype(i).ne.10) then
4068           do j=1,3
4069             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4070             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4071           enddo
4072         endif
4073         if (energy_dec) write (iout,*)
4074      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4075         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4076       enddo
4077
4078       endif
4079
4080 C      write (iout,*) ,"link_end",link_end,constr_dist
4081 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4082 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4083 c     &  " constr_dist",constr_dist
4084       if (link_end.eq.0.and.link_end_peak.eq.0) return
4085       do i=link_start_peak,link_end_peak
4086         ehpb_peak=0.0d0
4087 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4088 c     &   ipeak(1,i),ipeak(2,i)
4089         do ip=ipeak(1,i),ipeak(2,i)
4090           ii=ihpb_peak(ip)
4091           jj=jhpb_peak(ip)
4092           dd=dist(ii,jj)
4093           iip=ip-ipeak(1,i)+1
4094 C iii and jjj point to the residues for which the distance is assigned.
4095 c          if (ii.gt.nres) then
4096 c            iii=ii-nres
4097 c            jjj=jj-nres
4098 c          else
4099 c            iii=ii
4100 c            jjj=jj
4101 c          endif
4102           if (ii.gt.nres) then
4103             iii=ii-nres
4104           else
4105             iii=ii
4106           endif
4107           if (jj.gt.nres) then
4108             jjj=jj-nres
4109           else
4110             jjj=jj
4111           endif
4112           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4113           aux=dexp(-scal_peak*aux)
4114           ehpb_peak=ehpb_peak+aux
4115           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4116      &      forcon_peak(ip))*aux/dd
4117           do j=1,3
4118             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4119           enddo
4120           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4121      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4122      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4123         enddo
4124 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4125         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4126         do ip=ipeak(1,i),ipeak(2,i)
4127           iip=ip-ipeak(1,i)+1
4128           do j=1,3
4129             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4130           enddo
4131           ii=ihpb_peak(ip)
4132           jj=jhpb_peak(ip)
4133 C iii and jjj point to the residues for which the distance is assigned.
4134           if (ii.gt.nres) then
4135             iii=ii-nres
4136             jjj=jj-nres
4137           else
4138             iii=ii
4139             jjj=jj
4140           endif
4141           if (iii.lt.ii) then
4142             do j=1,3
4143               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4144             enddo
4145           endif
4146           if (jjj.lt.jj) then
4147             do j=1,3
4148               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4149             enddo
4150           endif
4151           do k=1,3
4152             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4153             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4154           enddo
4155         enddo
4156       enddo
4157       do i=link_start,link_end
4158 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4159 C CA-CA distance used in regularization of structure.
4160         ii=ihpb(i)
4161         jj=jhpb(i)
4162 C iii and jjj point to the residues for which the distance is assigned.
4163         if (ii.gt.nres) then
4164           iii=ii-nres
4165         else
4166           iii=ii
4167         endif
4168         if (jj.gt.nres) then
4169           jjj=jj-nres
4170         else
4171           jjj=jj
4172         endif
4173 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4174 c     &    dhpb(i),dhpb1(i),forcon(i)
4175 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4176 C    distance and angle dependent SS bond potential.
4177 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4178 C     & iabs(itype(jjj)).eq.1) then
4179 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4180 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4181         if (.not.dyn_ss .and. i.le.nss) then
4182 C 15/02/13 CC dynamic SSbond - additional check
4183           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4184      &        iabs(itype(jjj)).eq.1) then
4185            call ssbond_ene(iii,jjj,eij)
4186            ehpb=ehpb+2*eij
4187          endif
4188 cd          write (iout,*) "eij",eij
4189 cd   &   ' waga=',waga,' fac=',fac
4190 !        else if (ii.gt.nres .and. jj.gt.nres) then
4191         else
4192 C Calculate the distance between the two points and its difference from the
4193 C target distance.
4194           dd=dist(ii,jj)
4195           if (irestr_type(i).eq.11) then
4196             ehpb=ehpb+fordepth(i)!**4.0d0
4197      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4198             fac=fordepth(i)!**4.0d0
4199      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4200             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4201      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4202      &        ehpb,irestr_type(i)
4203           else if (irestr_type(i).eq.10) then
4204 c AL 6//19/2018 cross-link restraints
4205             xdis = 0.5d0*(dd/forcon(i))**2
4206             expdis = dexp(-xdis)
4207 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4208             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4209 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4210 c     &          " wboltzd",wboltzd
4211             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4212 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4213             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4214      &           *expdis/(aux*forcon(i)**2)
4215             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4216      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4217      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4218           else if (irestr_type(i).eq.2) then
4219 c Quartic restraints
4220             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4221             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4222      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4223      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4224             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4225           else
4226 c Quadratic restraints
4227             rdis=dd-dhpb(i)
4228 C Get the force constant corresponding to this distance.
4229             waga=forcon(i)
4230 C Calculate the contribution to energy.
4231             ehpb=ehpb+0.5d0*waga*rdis*rdis
4232             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4233      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4234      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4235 C
4236 C Evaluate gradient.
4237 C
4238             fac=waga*rdis/dd
4239           endif
4240 c Calculate Cartesian gradient
4241           do j=1,3
4242             ggg(j)=fac*(c(j,jj)-c(j,ii))
4243           enddo
4244 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4245 C If this is a SC-SC distance, we need to calculate the contributions to the
4246 C Cartesian gradient in the SC vectors (ghpbx).
4247           if (iii.lt.ii) then
4248             do j=1,3
4249               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4250             enddo
4251           endif
4252           if (jjj.lt.jj) then
4253             do j=1,3
4254               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4255             enddo
4256           endif
4257           do k=1,3
4258             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4259             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4260           enddo
4261         endif
4262       enddo
4263       return
4264       end
4265 C--------------------------------------------------------------------------
4266       subroutine ssbond_ene(i,j,eij)
4267 C
4268 C Calculate the distance and angle dependent SS-bond potential energy
4269 C using a free-energy function derived based on RHF/6-31G** ab initio
4270 C calculations of diethyl disulfide.
4271 C
4272 C A. Liwo and U. Kozlowska, 11/24/03
4273 C
4274       implicit real*8 (a-h,o-z)
4275       include 'DIMENSIONS'
4276       include 'DIMENSIONS.ZSCOPT'
4277       include 'COMMON.SBRIDGE'
4278       include 'COMMON.CHAIN'
4279       include 'COMMON.DERIV'
4280       include 'COMMON.LOCAL'
4281       include 'COMMON.INTERACT'
4282       include 'COMMON.VAR'
4283       include 'COMMON.IOUNITS'
4284       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4285       itypi=iabs(itype(i))
4286       xi=c(1,nres+i)
4287       yi=c(2,nres+i)
4288       zi=c(3,nres+i)
4289       dxi=dc_norm(1,nres+i)
4290       dyi=dc_norm(2,nres+i)
4291       dzi=dc_norm(3,nres+i)
4292       dsci_inv=dsc_inv(itypi)
4293       itypj=iabs(itype(j))
4294       dscj_inv=dsc_inv(itypj)
4295       xj=c(1,nres+j)-xi
4296       yj=c(2,nres+j)-yi
4297       zj=c(3,nres+j)-zi
4298       dxj=dc_norm(1,nres+j)
4299       dyj=dc_norm(2,nres+j)
4300       dzj=dc_norm(3,nres+j)
4301       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4302       rij=dsqrt(rrij)
4303       erij(1)=xj*rij
4304       erij(2)=yj*rij
4305       erij(3)=zj*rij
4306       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4307       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4308       om12=dxi*dxj+dyi*dyj+dzi*dzj
4309       do k=1,3
4310         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4311         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4312       enddo
4313       rij=1.0d0/rij
4314       deltad=rij-d0cm
4315       deltat1=1.0d0-om1
4316       deltat2=1.0d0+om2
4317       deltat12=om2-om1+2.0d0
4318       cosphi=om12-om1*om2
4319       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4320      &  +akct*deltad*deltat12
4321      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4322 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4323 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4324 c     &  " deltat12",deltat12," eij",eij
4325       ed=2*akcm*deltad+akct*deltat12
4326       pom1=akct*deltad
4327       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4328       eom1=-2*akth*deltat1-pom1-om2*pom2
4329       eom2= 2*akth*deltat2+pom1-om1*pom2
4330       eom12=pom2
4331       do k=1,3
4332         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4333       enddo
4334       do k=1,3
4335         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4336      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4337         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4338      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4339       enddo
4340 C
4341 C Calculate the components of the gradient in DC and X
4342 C
4343       do k=i,j-1
4344         do l=1,3
4345           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4346         enddo
4347       enddo
4348       return
4349       end
4350 C--------------------------------------------------------------------------
4351 c MODELLER restraint function
4352       subroutine e_modeller(ehomology_constr)
4353       implicit real*8 (a-h,o-z)
4354       include 'DIMENSIONS'
4355       include 'DIMENSIONS.ZSCOPT'
4356       include 'DIMENSIONS.FREE'
4357       integer nnn, i, j, k, ki, irec, l
4358       integer katy, odleglosci, test7
4359       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4360       real*8 distance(max_template),distancek(max_template),
4361      &    min_odl,godl(max_template),dih_diff(max_template)
4362
4363 c
4364 c     FP - 30/10/2014 Temporary specifications for homology restraints
4365 c
4366       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4367      &                 sgtheta
4368       double precision, dimension (maxres) :: guscdiff,usc_diff
4369       double precision, dimension (max_template) ::
4370      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4371      &           theta_diff
4372
4373       include 'COMMON.SBRIDGE'
4374       include 'COMMON.CHAIN'
4375       include 'COMMON.GEO'
4376       include 'COMMON.DERIV'
4377       include 'COMMON.LOCAL'
4378       include 'COMMON.INTERACT'
4379       include 'COMMON.VAR'
4380       include 'COMMON.IOUNITS'
4381       include 'COMMON.CONTROL'
4382       include 'COMMON.HOMRESTR'
4383       include 'COMMON.HOMOLOGY'
4384       include 'COMMON.SETUP'
4385       include 'COMMON.NAMES'
4386
4387       do i=1,max_template
4388         distancek(i)=9999999.9
4389       enddo
4390
4391       odleg=0.0d0
4392
4393 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4394 c function)
4395 C AL 5/2/14 - Introduce list of restraints
4396 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4397 #ifdef DEBUG
4398       write(iout,*) "------- dist restrs start -------"
4399 #endif
4400       do ii = link_start_homo,link_end_homo
4401          i = ires_homo(ii)
4402          j = jres_homo(ii)
4403          dij=dist(i,j)
4404 c        write (iout,*) "dij(",i,j,") =",dij
4405          nexl=0
4406          do k=1,constr_homology
4407            if(.not.l_homo(k,ii)) then
4408               nexl=nexl+1
4409               cycle
4410            endif
4411            distance(k)=odl(k,ii)-dij
4412 c          write (iout,*) "distance(",k,") =",distance(k)
4413 c
4414 c          For Gaussian-type Urestr
4415 c
4416            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4417 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4418 c          write (iout,*) "distancek(",k,") =",distancek(k)
4419 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4420 c
4421 c          For Lorentzian-type Urestr
4422 c
4423            if (waga_dist.lt.0.0d0) then
4424               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4425               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4426      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4427            endif
4428          enddo
4429
4430 c         min_odl=minval(distancek)
4431          if (nexl.gt.0) then
4432            min_odl=0.0d0
4433          else
4434            do kk=1,constr_homology
4435             if(l_homo(kk,ii)) then
4436               min_odl=distancek(kk)
4437               exit
4438             endif
4439            enddo
4440            do kk=1,constr_homology
4441             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4442      &              min_odl=distancek(kk)
4443            enddo
4444          endif
4445 c        write (iout,* )"min_odl",min_odl
4446 #ifdef DEBUG
4447          write (iout,*) "ij dij",i,j,dij
4448          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4449          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4450          write (iout,* )"min_odl",min_odl
4451 #endif
4452 #ifdef OLDRESTR
4453          odleg2=0.0d0
4454 #else
4455          if (waga_dist.ge.0.0d0) then
4456            odleg2=nexl
4457          else
4458            odleg2=0.0d0
4459          endif
4460 #endif
4461          do k=1,constr_homology
4462 c Nie wiem po co to liczycie jeszcze raz!
4463 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4464 c     &              (2*(sigma_odl(i,j,k))**2))
4465            if(.not.l_homo(k,ii)) cycle
4466            if (waga_dist.ge.0.0d0) then
4467 c
4468 c          For Gaussian-type Urestr
4469 c
4470             godl(k)=dexp(-distancek(k)+min_odl)
4471             odleg2=odleg2+godl(k)
4472 c
4473 c          For Lorentzian-type Urestr
4474 c
4475            else
4476             odleg2=odleg2+distancek(k)
4477            endif
4478
4479 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4480 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4481 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4482 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4483
4484          enddo
4485 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4486 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4487 #ifdef DEBUG
4488          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4489          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4490 #endif
4491            if (waga_dist.ge.0.0d0) then
4492 c
4493 c          For Gaussian-type Urestr
4494 c
4495               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4496 c
4497 c          For Lorentzian-type Urestr
4498 c
4499            else
4500               odleg=odleg+odleg2/constr_homology
4501            endif
4502 c
4503 #ifdef GRAD
4504 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4505 c Gradient
4506 c
4507 c          For Gaussian-type Urestr
4508 c
4509          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4510          sum_sgodl=0.0d0
4511          do k=1,constr_homology
4512 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4513 c     &           *waga_dist)+min_odl
4514 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4515 c
4516          if(.not.l_homo(k,ii)) cycle
4517          if (waga_dist.ge.0.0d0) then
4518 c          For Gaussian-type Urestr
4519 c
4520            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4521 c
4522 c          For Lorentzian-type Urestr
4523 c
4524          else
4525            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4526      &           sigma_odlir(k,ii)**2)**2)
4527          endif
4528            sum_sgodl=sum_sgodl+sgodl
4529
4530 c            sgodl2=sgodl2+sgodl
4531 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4532 c      write(iout,*) "constr_homology=",constr_homology
4533 c      write(iout,*) i, j, k, "TEST K"
4534          enddo
4535          if (waga_dist.ge.0.0d0) then
4536 c
4537 c          For Gaussian-type Urestr
4538 c
4539             grad_odl3=waga_homology(iset)*waga_dist
4540      &                *sum_sgodl/(sum_godl*dij)
4541 c
4542 c          For Lorentzian-type Urestr
4543 c
4544          else
4545 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4546 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4547             grad_odl3=-waga_homology(iset)*waga_dist*
4548      &                sum_sgodl/(constr_homology*dij)
4549          endif
4550 c
4551 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4552
4553
4554 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4555 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4556 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4557
4558 ccc      write(iout,*) godl, sgodl, grad_odl3
4559
4560 c          grad_odl=grad_odl+grad_odl3
4561
4562          do jik=1,3
4563             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4564 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4565 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4566 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4567             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4568             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4569 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4570 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4571 c         if (i.eq.25.and.j.eq.27) then
4572 c         write(iout,*) "jik",jik,"i",i,"j",j
4573 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4574 c         write(iout,*) "grad_odl3",grad_odl3
4575 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4576 c         write(iout,*) "ggodl",ggodl
4577 c         write(iout,*) "ghpbc(",jik,i,")",
4578 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4579 c     &                 ghpbc(jik,j)
4580 c         endif
4581          enddo
4582 #endif
4583 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4584 ccc     & dLOG(odleg2),"-odleg=", -odleg
4585
4586       enddo ! ii-loop for dist
4587 #ifdef DEBUG
4588       write(iout,*) "------- dist restrs end -------"
4589 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4590 c    &     waga_d.eq.1.0d0) call sum_gradient
4591 #endif
4592 c Pseudo-energy and gradient from dihedral-angle restraints from
4593 c homology templates
4594 c      write (iout,*) "End of distance loop"
4595 c      call flush(iout)
4596       kat=0.0d0
4597 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4598 #ifdef DEBUG
4599       write(iout,*) "------- dih restrs start -------"
4600       do i=idihconstr_start_homo,idihconstr_end_homo
4601         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4602       enddo
4603 #endif
4604       do i=idihconstr_start_homo,idihconstr_end_homo
4605         kat2=0.0d0
4606 c        betai=beta(i,i+1,i+2,i+3)
4607         betai = phi(i)
4608 c       write (iout,*) "betai =",betai
4609         do k=1,constr_homology
4610           dih_diff(k)=pinorm(dih(k,i)-betai)
4611 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4612 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4613 c     &                                   -(6.28318-dih_diff(i,k))
4614 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4615 c     &                                   6.28318+dih_diff(i,k)
4616 #ifdef OLD_DIHED
4617           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4618 #else
4619           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4620 #endif
4621 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4622           gdih(k)=dexp(kat3)
4623           kat2=kat2+gdih(k)
4624 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4625 c          write(*,*)""
4626         enddo
4627 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4628 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4629 #ifdef DEBUG
4630         write (iout,*) "i",i," betai",betai," kat2",kat2
4631         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4632 #endif
4633         if (kat2.le.1.0d-14) cycle
4634         kat=kat-dLOG(kat2/constr_homology)
4635 c       write (iout,*) "kat",kat ! sum of -ln-s
4636
4637 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4638 ccc     & dLOG(kat2), "-kat=", -kat
4639
4640 #ifdef GRAD
4641 c ----------------------------------------------------------------------
4642 c Gradient
4643 c ----------------------------------------------------------------------
4644
4645         sum_gdih=kat2
4646         sum_sgdih=0.0d0
4647         do k=1,constr_homology
4648 #ifdef OLD_DIHED
4649           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4650 #else
4651           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4652 #endif
4653 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4654           sum_sgdih=sum_sgdih+sgdih
4655         enddo
4656 c       grad_dih3=sum_sgdih/sum_gdih
4657         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4658
4659 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4660 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4661 ccc     & gloc(nphi+i-3,icg)
4662         gloc(i,icg)=gloc(i,icg)+grad_dih3
4663 c        if (i.eq.25) then
4664 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4665 c        endif
4666 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4667 ccc     & gloc(nphi+i-3,icg)
4668 #endif
4669       enddo ! i-loop for dih
4670 #ifdef DEBUG
4671       write(iout,*) "------- dih restrs end -------"
4672 #endif
4673
4674 c Pseudo-energy and gradient for theta angle restraints from
4675 c homology templates
4676 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4677 c adapted
4678
4679 c
4680 c     For constr_homology reference structures (FP)
4681 c
4682 c     Uconst_back_tot=0.0d0
4683       Eval=0.0d0
4684       Erot=0.0d0
4685 c     Econstr_back legacy
4686 #ifdef GRAD
4687       do i=1,nres
4688 c     do i=ithet_start,ithet_end
4689        dutheta(i)=0.0d0
4690 c     enddo
4691 c     do i=loc_start,loc_end
4692         do j=1,3
4693           duscdiff(j,i)=0.0d0
4694           duscdiffx(j,i)=0.0d0
4695         enddo
4696       enddo
4697 #endif
4698 c
4699 c     do iref=1,nref
4700 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4701 c     write (iout,*) "waga_theta",waga_theta
4702       if (waga_theta.gt.0.0d0) then
4703 #ifdef DEBUG
4704       write (iout,*) "usampl",usampl
4705       write(iout,*) "------- theta restrs start -------"
4706 c     do i=ithet_start,ithet_end
4707 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4708 c     enddo
4709 #endif
4710 c     write (iout,*) "maxres",maxres,"nres",nres
4711
4712       do i=ithet_start,ithet_end
4713 c
4714 c     do i=1,nfrag_back
4715 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4716 c
4717 c Deviation of theta angles wrt constr_homology ref structures
4718 c
4719         utheta_i=0.0d0 ! argument of Gaussian for single k
4720         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4721 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4722 c       over residues in a fragment
4723 c       write (iout,*) "theta(",i,")=",theta(i)
4724         do k=1,constr_homology
4725 c
4726 c         dtheta_i=theta(j)-thetaref(j,iref)
4727 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4728           theta_diff(k)=thetatpl(k,i)-theta(i)
4729 c
4730           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4731 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4732           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4733           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4734 c         Gradient for single Gaussian restraint in subr Econstr_back
4735 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4736 c
4737         enddo
4738 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4739 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4740
4741 c
4742 #ifdef GRAD
4743 c         Gradient for multiple Gaussian restraint
4744         sum_gtheta=gutheta_i
4745         sum_sgtheta=0.0d0
4746         do k=1,constr_homology
4747 c        New generalized expr for multiple Gaussian from Econstr_back
4748          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4749 c
4750 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4751           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4752         enddo
4753 c
4754 c       Final value of gradient using same var as in Econstr_back
4755         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4756      &               *waga_homology(iset)
4757 c       dutheta(i)=sum_sgtheta/sum_gtheta
4758 c
4759 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4760 #endif
4761         Eval=Eval-dLOG(gutheta_i/constr_homology)
4762 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4763 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4764 c       Uconst_back=Uconst_back+utheta(i)
4765       enddo ! (i-loop for theta)
4766 #ifdef DEBUG
4767       write(iout,*) "------- theta restrs end -------"
4768 #endif
4769       endif
4770 c
4771 c Deviation of local SC geometry
4772 c
4773 c Separation of two i-loops (instructed by AL - 11/3/2014)
4774 c
4775 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4776 c     write (iout,*) "waga_d",waga_d
4777
4778 #ifdef DEBUG
4779       write(iout,*) "------- SC restrs start -------"
4780       write (iout,*) "Initial duscdiff,duscdiffx"
4781       do i=loc_start,loc_end
4782         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4783      &                 (duscdiffx(jik,i),jik=1,3)
4784       enddo
4785 #endif
4786       do i=loc_start,loc_end
4787         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4788         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4789 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4790 c       write(iout,*) "xxtab, yytab, zztab"
4791 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4792         do k=1,constr_homology
4793 c
4794           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4795 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4796           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4797           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4798 c         write(iout,*) "dxx, dyy, dzz"
4799 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4800 c
4801           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4802 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4803 c         uscdiffk(k)=usc_diff(i)
4804           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4805           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4806 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4807 c     &      xxref(j),yyref(j),zzref(j)
4808         enddo
4809 c
4810 c       Gradient
4811 c
4812 c       Generalized expression for multiple Gaussian acc to that for a single
4813 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4814 c
4815 c       Original implementation
4816 c       sum_guscdiff=guscdiff(i)
4817 c
4818 c       sum_sguscdiff=0.0d0
4819 c       do k=1,constr_homology
4820 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4821 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4822 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4823 c       enddo
4824 c
4825 c       Implementation of new expressions for gradient (Jan. 2015)
4826 c
4827 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4828 #ifdef GRAD
4829         do k=1,constr_homology
4830 c
4831 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4832 c       before. Now the drivatives should be correct
4833 c
4834           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4835 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4836           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4837           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4838 c
4839 c         New implementation
4840 c
4841           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4842      &                 sigma_d(k,i) ! for the grad wrt r'
4843 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4844 c
4845 c
4846 c        New implementation
4847          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4848          do jik=1,3
4849             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4850      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4851      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4852             duscdiff(jik,i)=duscdiff(jik,i)+
4853      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4854      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4855             duscdiffx(jik,i)=duscdiffx(jik,i)+
4856      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4857      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4858 c
4859 #ifdef DEBUG
4860              write(iout,*) "jik",jik,"i",i
4861              write(iout,*) "dxx, dyy, dzz"
4862              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4863              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4864 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4865 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4866 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4867 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4868 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4869 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4870 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4871 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4872 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4873 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4874 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4875 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4876 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4877 c            endif
4878 #endif
4879          enddo
4880         enddo
4881 #endif
4882 c
4883 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4884 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4885 c
4886 c        write (iout,*) i," uscdiff",uscdiff(i)
4887 c
4888 c Put together deviations from local geometry
4889
4890 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4891 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4892         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4893 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4894 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4895 c       Uconst_back=Uconst_back+usc_diff(i)
4896 c
4897 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4898 c
4899 c     New implment: multiplied by sum_sguscdiff
4900 c
4901
4902       enddo ! (i-loop for dscdiff)
4903
4904 c      endif
4905
4906 #ifdef DEBUG
4907       write(iout,*) "------- SC restrs end -------"
4908         write (iout,*) "------ After SC loop in e_modeller ------"
4909         do i=loc_start,loc_end
4910          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4911          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4912         enddo
4913       if (waga_theta.eq.1.0d0) then
4914       write (iout,*) "in e_modeller after SC restr end: dutheta"
4915       do i=ithet_start,ithet_end
4916         write (iout,*) i,dutheta(i)
4917       enddo
4918       endif
4919       if (waga_d.eq.1.0d0) then
4920       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4921       do i=1,nres
4922         write (iout,*) i,(duscdiff(j,i),j=1,3)
4923         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4924       enddo
4925       endif
4926 #endif
4927
4928 c Total energy from homology restraints
4929 #ifdef DEBUG
4930       write (iout,*) "odleg",odleg," kat",kat
4931       write (iout,*) "odleg",odleg," kat",kat
4932       write (iout,*) "Eval",Eval," Erot",Erot
4933       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4934       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4935       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4936 #endif
4937 c
4938 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4939 c
4940 c     ehomology_constr=odleg+kat
4941 c
4942 c     For Lorentzian-type Urestr
4943 c
4944
4945       if (waga_dist.ge.0.0d0) then
4946 c
4947 c          For Gaussian-type Urestr
4948 c
4949 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4950 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4951         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4952      &              waga_theta*Eval+waga_d*Erot
4953 c     write (iout,*) "ehomology_constr=",ehomology_constr
4954       else
4955 c
4956 c          For Lorentzian-type Urestr
4957 c
4958 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4959 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4960         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4961      &              waga_theta*Eval+waga_d*Erot
4962 c     write (iout,*) "ehomology_constr=",ehomology_constr
4963       endif
4964 #ifdef DEBUG
4965       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4966      & "Eval",waga_theta,eval,
4967      &   "Erot",waga_d,Erot
4968       write (iout,*) "ehomology_constr",ehomology_constr
4969 #endif
4970       return
4971
4972   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4973   747 format(a12,i4,i4,i4,f8.3,f8.3)
4974   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4975   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4976   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4977      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4978       end
4979 c-----------------------------------------------------------------------
4980       subroutine ebond(estr)
4981 c
4982 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4983 c
4984       implicit real*8 (a-h,o-z)
4985       include 'DIMENSIONS'
4986       include 'DIMENSIONS.ZSCOPT'
4987       include 'COMMON.LOCAL'
4988       include 'COMMON.GEO'
4989       include 'COMMON.INTERACT'
4990       include 'COMMON.DERIV'
4991       include 'COMMON.VAR'
4992       include 'COMMON.CHAIN'
4993       include 'COMMON.IOUNITS'
4994       include 'COMMON.NAMES'
4995       include 'COMMON.FFIELD'
4996       include 'COMMON.CONTROL'
4997       double precision u(3),ud(3)
4998       estr=0.0d0
4999       estr1=0.0d0
5000 c      write (iout,*) "distchainmax",distchainmax
5001       do i=nnt+1,nct
5002 #ifdef FIVEDIAG
5003         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5004         diff = vbld(i)-vbldp0
5005 #else
5006         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5007 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5008 C          do j=1,3
5009 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5010 C     &      *dc(j,i-1)/vbld(i)
5011 C          enddo
5012 C          if (energy_dec) write(iout,*)
5013 C     &       "estr1",i,vbld(i),distchainmax,
5014 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5015 C        else
5016          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5017         diff = vbld(i)-vbldpDUM
5018 C         write(iout,*) i,diff
5019          else
5020           diff = vbld(i)-vbldp0
5021 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5022          endif
5023 #endif
5024           estr=estr+diff*diff
5025           do j=1,3
5026             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5027           enddo
5028 C        endif
5029           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5030      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5031       enddo
5032       estr=0.5d0*AKP*estr+estr1
5033 c
5034 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5035 c
5036       do i=nnt,nct
5037         iti=iabs(itype(i))
5038         if (iti.ne.10 .and. iti.ne.ntyp1) then
5039           nbi=nbondterm(iti)
5040           if (nbi.eq.1) then
5041             diff=vbld(i+nres)-vbldsc0(1,iti)
5042             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5043      &      vbldsc0(1,iti),diff,
5044      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5045             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5046             do j=1,3
5047               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5048             enddo
5049           else
5050             do j=1,nbi
5051               diff=vbld(i+nres)-vbldsc0(j,iti)
5052               ud(j)=aksc(j,iti)*diff
5053               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5054             enddo
5055             uprod=u(1)
5056             do j=2,nbi
5057               uprod=uprod*u(j)
5058             enddo
5059             usum=0.0d0
5060             usumsqder=0.0d0
5061             do j=1,nbi
5062               uprod1=1.0d0
5063               uprod2=1.0d0
5064               do k=1,nbi
5065                 if (k.ne.j) then
5066                   uprod1=uprod1*u(k)
5067                   uprod2=uprod2*u(k)*u(k)
5068                 endif
5069               enddo
5070               usum=usum+uprod1
5071               usumsqder=usumsqder+ud(j)*uprod2
5072             enddo
5073 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5074 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5075             estr=estr+uprod/usum
5076             do j=1,3
5077              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5078             enddo
5079           endif
5080         endif
5081       enddo
5082       return
5083       end
5084 #ifdef CRYST_THETA
5085 C--------------------------------------------------------------------------
5086       subroutine ebend(etheta,ethetacnstr)
5087 C
5088 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5089 C angles gamma and its derivatives in consecutive thetas and gammas.
5090 C
5091       implicit real*8 (a-h,o-z)
5092       include 'DIMENSIONS'
5093       include 'DIMENSIONS.ZSCOPT'
5094       include 'COMMON.LOCAL'
5095       include 'COMMON.GEO'
5096       include 'COMMON.INTERACT'
5097       include 'COMMON.DERIV'
5098       include 'COMMON.VAR'
5099       include 'COMMON.CHAIN'
5100       include 'COMMON.IOUNITS'
5101       include 'COMMON.NAMES'
5102       include 'COMMON.FFIELD'
5103       include 'COMMON.TORCNSTR'
5104       common /calcthet/ term1,term2,termm,diffak,ratak,
5105      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5106      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5107       double precision y(2),z(2)
5108       delta=0.02d0*pi
5109 c      time11=dexp(-2*time)
5110 c      time12=1.0d0
5111       etheta=0.0D0
5112 c      write (iout,*) "nres",nres
5113 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5114 c      write (iout,*) ithet_start,ithet_end
5115       do i=ithet_start,ithet_end
5116 C        if (itype(i-1).eq.ntyp1) cycle
5117         if (i.le.2) cycle
5118         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5119      &  .or.itype(i).eq.ntyp1) cycle
5120 C Zero the energy function and its derivative at 0 or pi.
5121         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5122         it=itype(i-1)
5123         ichir1=isign(1,itype(i-2))
5124         ichir2=isign(1,itype(i))
5125          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5126          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5127          if (itype(i-1).eq.10) then
5128           itype1=isign(10,itype(i-2))
5129           ichir11=isign(1,itype(i-2))
5130           ichir12=isign(1,itype(i-2))
5131           itype2=isign(10,itype(i))
5132           ichir21=isign(1,itype(i))
5133           ichir22=isign(1,itype(i))
5134          endif
5135          if (i.eq.3) then
5136           y(1)=0.0D0
5137           y(2)=0.0D0
5138           else
5139
5140         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5141 #ifdef OSF
5142           phii=phi(i)
5143 c          icrc=0
5144 c          call proc_proc(phii,icrc)
5145           if (icrc.eq.1) phii=150.0
5146 #else
5147           phii=phi(i)
5148 #endif
5149           y(1)=dcos(phii)
5150           y(2)=dsin(phii)
5151         else
5152           y(1)=0.0D0
5153           y(2)=0.0D0
5154         endif
5155         endif
5156         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5157 #ifdef OSF
5158           phii1=phi(i+1)
5159 c          icrc=0
5160 c          call proc_proc(phii1,icrc)
5161           if (icrc.eq.1) phii1=150.0
5162           phii1=pinorm(phii1)
5163           z(1)=cos(phii1)
5164 #else
5165           phii1=phi(i+1)
5166           z(1)=dcos(phii1)
5167 #endif
5168           z(2)=dsin(phii1)
5169         else
5170           z(1)=0.0D0
5171           z(2)=0.0D0
5172         endif
5173 C Calculate the "mean" value of theta from the part of the distribution
5174 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5175 C In following comments this theta will be referred to as t_c.
5176         thet_pred_mean=0.0d0
5177         do k=1,2
5178             athetk=athet(k,it,ichir1,ichir2)
5179             bthetk=bthet(k,it,ichir1,ichir2)
5180           if (it.eq.10) then
5181              athetk=athet(k,itype1,ichir11,ichir12)
5182              bthetk=bthet(k,itype2,ichir21,ichir22)
5183           endif
5184           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5185         enddo
5186 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5187         dthett=thet_pred_mean*ssd
5188         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5189 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5190 C Derivatives of the "mean" values in gamma1 and gamma2.
5191         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5192      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5193          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5194      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5195          if (it.eq.10) then
5196       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5197      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5198         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5199      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5200          endif
5201         if (theta(i).gt.pi-delta) then
5202           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5203      &         E_tc0)
5204           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5205           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5206           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5207      &        E_theta)
5208           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5209      &        E_tc)
5210         else if (theta(i).lt.delta) then
5211           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5212           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5213           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5214      &        E_theta)
5215           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5216           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5217      &        E_tc)
5218         else
5219           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5220      &        E_theta,E_tc)
5221         endif
5222         etheta=etheta+ethetai
5223 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5224 c     &      'ebend',i,ethetai,theta(i),itype(i)
5225 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5226 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5227         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5228         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5229         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5230 c 1215   continue
5231       enddo
5232       ethetacnstr=0.0d0
5233 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5234       do i=1,ntheta_constr
5235         itheta=itheta_constr(i)
5236         thetiii=theta(itheta)
5237         difi=pinorm(thetiii-theta_constr0(i))
5238         if (difi.gt.theta_drange(i)) then
5239           difi=difi-theta_drange(i)
5240           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5241           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5242      &    +for_thet_constr(i)*difi**3
5243         else if (difi.lt.-drange(i)) then
5244           difi=difi+drange(i)
5245           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5246           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5247      &    +for_thet_constr(i)*difi**3
5248         else
5249           difi=0.0
5250         endif
5251 C       if (energy_dec) then
5252 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5253 C     &    i,itheta,rad2deg*thetiii,
5254 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5255 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5256 C     &    gloc(itheta+nphi-2,icg)
5257 C        endif
5258       enddo
5259 C Ufff.... We've done all this!!!
5260       return
5261       end
5262 C---------------------------------------------------------------------------
5263       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5264      &     E_tc)
5265       implicit real*8 (a-h,o-z)
5266       include 'DIMENSIONS'
5267       include 'COMMON.LOCAL'
5268       include 'COMMON.IOUNITS'
5269       common /calcthet/ term1,term2,termm,diffak,ratak,
5270      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5271      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5272 C Calculate the contributions to both Gaussian lobes.
5273 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5274 C The "polynomial part" of the "standard deviation" of this part of
5275 C the distribution.
5276         sig=polthet(3,it)
5277         do j=2,0,-1
5278           sig=sig*thet_pred_mean+polthet(j,it)
5279         enddo
5280 C Derivative of the "interior part" of the "standard deviation of the"
5281 C gamma-dependent Gaussian lobe in t_c.
5282         sigtc=3*polthet(3,it)
5283         do j=2,1,-1
5284           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5285         enddo
5286         sigtc=sig*sigtc
5287 C Set the parameters of both Gaussian lobes of the distribution.
5288 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5289         fac=sig*sig+sigc0(it)
5290         sigcsq=fac+fac
5291         sigc=1.0D0/sigcsq
5292 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5293         sigsqtc=-4.0D0*sigcsq*sigtc
5294 c       print *,i,sig,sigtc,sigsqtc
5295 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5296         sigtc=-sigtc/(fac*fac)
5297 C Following variable is sigma(t_c)**(-2)
5298         sigcsq=sigcsq*sigcsq
5299         sig0i=sig0(it)
5300         sig0inv=1.0D0/sig0i**2
5301         delthec=thetai-thet_pred_mean
5302         delthe0=thetai-theta0i
5303         term1=-0.5D0*sigcsq*delthec*delthec
5304         term2=-0.5D0*sig0inv*delthe0*delthe0
5305 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5306 C NaNs in taking the logarithm. We extract the largest exponent which is added
5307 C to the energy (this being the log of the distribution) at the end of energy
5308 C term evaluation for this virtual-bond angle.
5309         if (term1.gt.term2) then
5310           termm=term1
5311           term2=dexp(term2-termm)
5312           term1=1.0d0
5313         else
5314           termm=term2
5315           term1=dexp(term1-termm)
5316           term2=1.0d0
5317         endif
5318 C The ratio between the gamma-independent and gamma-dependent lobes of
5319 C the distribution is a Gaussian function of thet_pred_mean too.
5320         diffak=gthet(2,it)-thet_pred_mean
5321         ratak=diffak/gthet(3,it)**2
5322         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5323 C Let's differentiate it in thet_pred_mean NOW.
5324         aktc=ak*ratak
5325 C Now put together the distribution terms to make complete distribution.
5326         termexp=term1+ak*term2
5327         termpre=sigc+ak*sig0i
5328 C Contribution of the bending energy from this theta is just the -log of
5329 C the sum of the contributions from the two lobes and the pre-exponential
5330 C factor. Simple enough, isn't it?
5331         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5332 C NOW the derivatives!!!
5333 C 6/6/97 Take into account the deformation.
5334         E_theta=(delthec*sigcsq*term1
5335      &       +ak*delthe0*sig0inv*term2)/termexp
5336         E_tc=((sigtc+aktc*sig0i)/termpre
5337      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5338      &       aktc*term2)/termexp)
5339       return
5340       end
5341 c-----------------------------------------------------------------------------
5342       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5343       implicit real*8 (a-h,o-z)
5344       include 'DIMENSIONS'
5345       include 'COMMON.LOCAL'
5346       include 'COMMON.IOUNITS'
5347       common /calcthet/ term1,term2,termm,diffak,ratak,
5348      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5349      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5350       delthec=thetai-thet_pred_mean
5351       delthe0=thetai-theta0i
5352 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5353       t3 = thetai-thet_pred_mean
5354       t6 = t3**2
5355       t9 = term1
5356       t12 = t3*sigcsq
5357       t14 = t12+t6*sigsqtc
5358       t16 = 1.0d0
5359       t21 = thetai-theta0i
5360       t23 = t21**2
5361       t26 = term2
5362       t27 = t21*t26
5363       t32 = termexp
5364       t40 = t32**2
5365       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5366      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5367      & *(-t12*t9-ak*sig0inv*t27)
5368       return
5369       end
5370 #else
5371 C--------------------------------------------------------------------------
5372       subroutine ebend(etheta)
5373 C
5374 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5375 C angles gamma and its derivatives in consecutive thetas and gammas.
5376 C ab initio-derived potentials from
5377 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5378 C
5379       implicit real*8 (a-h,o-z)
5380       include 'DIMENSIONS'
5381       include 'DIMENSIONS.ZSCOPT'
5382       include 'COMMON.LOCAL'
5383       include 'COMMON.GEO'
5384       include 'COMMON.INTERACT'
5385       include 'COMMON.DERIV'
5386       include 'COMMON.VAR'
5387       include 'COMMON.CHAIN'
5388       include 'COMMON.IOUNITS'
5389       include 'COMMON.NAMES'
5390       include 'COMMON.FFIELD'
5391       include 'COMMON.CONTROL'
5392       include 'COMMON.TORCNSTR'
5393       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5394      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5395      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5396      & sinph1ph2(maxdouble,maxdouble)
5397       logical lprn /.false./, lprn1 /.false./
5398       etheta=0.0D0
5399 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5400       do i=ithet_start,ithet_end
5401 C         if (i.eq.2) cycle
5402 C        if (itype(i-1).eq.ntyp1) cycle
5403         if (i.le.2) cycle
5404         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5405      &  .or.itype(i).eq.ntyp1) cycle
5406         if (iabs(itype(i+1)).eq.20) iblock=2
5407         if (iabs(itype(i+1)).ne.20) iblock=1
5408         dethetai=0.0d0
5409         dephii=0.0d0
5410         dephii1=0.0d0
5411         theti2=0.5d0*theta(i)
5412         ityp2=ithetyp((itype(i-1)))
5413         do k=1,nntheterm
5414           coskt(k)=dcos(k*theti2)
5415           sinkt(k)=dsin(k*theti2)
5416         enddo
5417 cu        if (i.eq.3) then
5418 cu          phii=0.0d0
5419 cu          ityp1=nthetyp+1
5420 cu          do k=1,nsingle
5421 cu            cosph1(k)=0.0d0
5422 cu            sinph1(k)=0.0d0
5423 cu          enddo
5424 cu        else
5425         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5426 #ifdef OSF
5427           phii=phi(i)
5428           if (phii.ne.phii) phii=150.0
5429 #else
5430           phii=phi(i)
5431 #endif
5432           ityp1=ithetyp((itype(i-2)))
5433           do k=1,nsingle
5434             cosph1(k)=dcos(k*phii)
5435             sinph1(k)=dsin(k*phii)
5436           enddo
5437         else
5438           phii=0.0d0
5439 c          ityp1=nthetyp+1
5440           do k=1,nsingle
5441             ityp1=ithetyp((itype(i-2)))
5442             cosph1(k)=0.0d0
5443             sinph1(k)=0.0d0
5444           enddo
5445         endif
5446         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5447 #ifdef OSF
5448           phii1=phi(i+1)
5449           if (phii1.ne.phii1) phii1=150.0
5450           phii1=pinorm(phii1)
5451 #else
5452           phii1=phi(i+1)
5453 #endif
5454           ityp3=ithetyp((itype(i)))
5455           do k=1,nsingle
5456             cosph2(k)=dcos(k*phii1)
5457             sinph2(k)=dsin(k*phii1)
5458           enddo
5459         else
5460           phii1=0.0d0
5461 c          ityp3=nthetyp+1
5462           ityp3=ithetyp((itype(i)))
5463           do k=1,nsingle
5464             cosph2(k)=0.0d0
5465             sinph2(k)=0.0d0
5466           enddo
5467         endif
5468 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5469 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5470 c        call flush(iout)
5471         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5472         do k=1,ndouble
5473           do l=1,k-1
5474             ccl=cosph1(l)*cosph2(k-l)
5475             ssl=sinph1(l)*sinph2(k-l)
5476             scl=sinph1(l)*cosph2(k-l)
5477             csl=cosph1(l)*sinph2(k-l)
5478             cosph1ph2(l,k)=ccl-ssl
5479             cosph1ph2(k,l)=ccl+ssl
5480             sinph1ph2(l,k)=scl+csl
5481             sinph1ph2(k,l)=scl-csl
5482           enddo
5483         enddo
5484         if (lprn) then
5485         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5486      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5487         write (iout,*) "coskt and sinkt"
5488         do k=1,nntheterm
5489           write (iout,*) k,coskt(k),sinkt(k)
5490         enddo
5491         endif
5492         do k=1,ntheterm
5493           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5494           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5495      &      *coskt(k)
5496           if (lprn)
5497      &    write (iout,*) "k",k,"
5498      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5499      &     " ethetai",ethetai
5500         enddo
5501         if (lprn) then
5502         write (iout,*) "cosph and sinph"
5503         do k=1,nsingle
5504           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5505         enddo
5506         write (iout,*) "cosph1ph2 and sinph2ph2"
5507         do k=2,ndouble
5508           do l=1,k-1
5509             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5510      &         sinph1ph2(l,k),sinph1ph2(k,l)
5511           enddo
5512         enddo
5513         write(iout,*) "ethetai",ethetai
5514         endif
5515         do m=1,ntheterm2
5516           do k=1,nsingle
5517             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5518      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5519      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5520      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5521             ethetai=ethetai+sinkt(m)*aux
5522             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5523             dephii=dephii+k*sinkt(m)*(
5524      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5525      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5526             dephii1=dephii1+k*sinkt(m)*(
5527      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5528      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5529             if (lprn)
5530      &      write (iout,*) "m",m," k",k," bbthet",
5531      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5532      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5533      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5534      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5535           enddo
5536         enddo
5537         if (lprn)
5538      &  write(iout,*) "ethetai",ethetai
5539         do m=1,ntheterm3
5540           do k=2,ndouble
5541             do l=1,k-1
5542               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5543      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5544      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5545      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5546               ethetai=ethetai+sinkt(m)*aux
5547               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5548               dephii=dephii+l*sinkt(m)*(
5549      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5550      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5551      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5552      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5553               dephii1=dephii1+(k-l)*sinkt(m)*(
5554      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5555      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5556      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5557      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5558               if (lprn) then
5559               write (iout,*) "m",m," k",k," l",l," ffthet",
5560      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5561      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5562      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5563      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5564      &            " ethetai",ethetai
5565               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5566      &            cosph1ph2(k,l)*sinkt(m),
5567      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5568               endif
5569             enddo
5570           enddo
5571         enddo
5572 10      continue
5573         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5574      &   i,theta(i)*rad2deg,phii*rad2deg,
5575      &   phii1*rad2deg,ethetai
5576         etheta=etheta+ethetai
5577         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5578         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5579 c        gloc(nphi+i-2,icg)=wang*dethetai
5580         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5581       enddo
5582       return
5583       end
5584 #endif
5585 #ifdef CRYST_SC
5586 c-----------------------------------------------------------------------------
5587       subroutine esc(escloc)
5588 C Calculate the local energy of a side chain and its derivatives in the
5589 C corresponding virtual-bond valence angles THETA and the spherical angles
5590 C ALPHA and OMEGA.
5591       implicit real*8 (a-h,o-z)
5592       include 'DIMENSIONS'
5593       include 'DIMENSIONS.ZSCOPT'
5594       include 'COMMON.GEO'
5595       include 'COMMON.LOCAL'
5596       include 'COMMON.VAR'
5597       include 'COMMON.INTERACT'
5598       include 'COMMON.DERIV'
5599       include 'COMMON.CHAIN'
5600       include 'COMMON.IOUNITS'
5601       include 'COMMON.NAMES'
5602       include 'COMMON.FFIELD'
5603       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5604      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5605       common /sccalc/ time11,time12,time112,theti,it,nlobit
5606       delta=0.02d0*pi
5607       escloc=0.0D0
5608 C      write (iout,*) 'ESC'
5609       do i=loc_start,loc_end
5610         it=itype(i)
5611         if (it.eq.ntyp1) cycle
5612         if (it.eq.10) goto 1
5613         nlobit=nlob(iabs(it))
5614 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5615 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5616         theti=theta(i+1)-pipol
5617         x(1)=dtan(theti)
5618         x(2)=alph(i)
5619         x(3)=omeg(i)
5620 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5621
5622         if (x(2).gt.pi-delta) then
5623           xtemp(1)=x(1)
5624           xtemp(2)=pi-delta
5625           xtemp(3)=x(3)
5626           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5627           xtemp(2)=pi
5628           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5629           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5630      &        escloci,dersc(2))
5631           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5632      &        ddersc0(1),dersc(1))
5633           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5634      &        ddersc0(3),dersc(3))
5635           xtemp(2)=pi-delta
5636           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5637           xtemp(2)=pi
5638           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5639           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5640      &            dersc0(2),esclocbi,dersc02)
5641           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5642      &            dersc12,dersc01)
5643           call splinthet(x(2),0.5d0*delta,ss,ssd)
5644           dersc0(1)=dersc01
5645           dersc0(2)=dersc02
5646           dersc0(3)=0.0d0
5647           do k=1,3
5648             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5649           enddo
5650           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5651           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5652      &             esclocbi,ss,ssd
5653           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5654 c         escloci=esclocbi
5655 c         write (iout,*) escloci
5656         else if (x(2).lt.delta) then
5657           xtemp(1)=x(1)
5658           xtemp(2)=delta
5659           xtemp(3)=x(3)
5660           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5661           xtemp(2)=0.0d0
5662           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5663           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5664      &        escloci,dersc(2))
5665           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5666      &        ddersc0(1),dersc(1))
5667           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5668      &        ddersc0(3),dersc(3))
5669           xtemp(2)=delta
5670           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5671           xtemp(2)=0.0d0
5672           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5673           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5674      &            dersc0(2),esclocbi,dersc02)
5675           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5676      &            dersc12,dersc01)
5677           dersc0(1)=dersc01
5678           dersc0(2)=dersc02
5679           dersc0(3)=0.0d0
5680           call splinthet(x(2),0.5d0*delta,ss,ssd)
5681           do k=1,3
5682             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5683           enddo
5684           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5685 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5686 c     &             esclocbi,ss,ssd
5687           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5688 C         write (iout,*) 'i=',i, escloci
5689         else
5690           call enesc(x,escloci,dersc,ddummy,.false.)
5691         endif
5692
5693         escloc=escloc+escloci
5694 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5695             write (iout,'(a6,i5,0pf7.3)')
5696      &     'escloc',i,escloci
5697
5698         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5699      &   wscloc*dersc(1)
5700         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5701         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5702     1   continue
5703       enddo
5704       return
5705       end
5706 C---------------------------------------------------------------------------
5707       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5708       implicit real*8 (a-h,o-z)
5709       include 'DIMENSIONS'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.IOUNITS'
5713       common /sccalc/ time11,time12,time112,theti,it,nlobit
5714       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5715       double precision contr(maxlob,-1:1)
5716       logical mixed
5717 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5718         escloc_i=0.0D0
5719         do j=1,3
5720           dersc(j)=0.0D0
5721           if (mixed) ddersc(j)=0.0d0
5722         enddo
5723         x3=x(3)
5724
5725 C Because of periodicity of the dependence of the SC energy in omega we have
5726 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5727 C To avoid underflows, first compute & store the exponents.
5728
5729         do iii=-1,1
5730
5731           x(3)=x3+iii*dwapi
5732
5733           do j=1,nlobit
5734             do k=1,3
5735               z(k)=x(k)-censc(k,j,it)
5736             enddo
5737             do k=1,3
5738               Axk=0.0D0
5739               do l=1,3
5740                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5741               enddo
5742               Ax(k,j,iii)=Axk
5743             enddo
5744             expfac=0.0D0
5745             do k=1,3
5746               expfac=expfac+Ax(k,j,iii)*z(k)
5747             enddo
5748             contr(j,iii)=expfac
5749           enddo ! j
5750
5751         enddo ! iii
5752
5753         x(3)=x3
5754 C As in the case of ebend, we want to avoid underflows in exponentiation and
5755 C subsequent NaNs and INFs in energy calculation.
5756 C Find the largest exponent
5757         emin=contr(1,-1)
5758         do iii=-1,1
5759           do j=1,nlobit
5760             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5761           enddo
5762         enddo
5763         emin=0.5D0*emin
5764 cd      print *,'it=',it,' emin=',emin
5765
5766 C Compute the contribution to SC energy and derivatives
5767         do iii=-1,1
5768
5769           do j=1,nlobit
5770             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5771 cd          print *,'j=',j,' expfac=',expfac
5772             escloc_i=escloc_i+expfac
5773             do k=1,3
5774               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5775             enddo
5776             if (mixed) then
5777               do k=1,3,2
5778                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5779      &            +gaussc(k,2,j,it))*expfac
5780               enddo
5781             endif
5782           enddo
5783
5784         enddo ! iii
5785
5786         dersc(1)=dersc(1)/cos(theti)**2
5787         ddersc(1)=ddersc(1)/cos(theti)**2
5788         ddersc(3)=ddersc(3)
5789
5790         escloci=-(dlog(escloc_i)-emin)
5791         do j=1,3
5792           dersc(j)=dersc(j)/escloc_i
5793         enddo
5794         if (mixed) then
5795           do j=1,3,2
5796             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5797           enddo
5798         endif
5799       return
5800       end
5801 C------------------------------------------------------------------------------
5802       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5803       implicit real*8 (a-h,o-z)
5804       include 'DIMENSIONS'
5805       include 'COMMON.GEO'
5806       include 'COMMON.LOCAL'
5807       include 'COMMON.IOUNITS'
5808       common /sccalc/ time11,time12,time112,theti,it,nlobit
5809       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5810       double precision contr(maxlob)
5811       logical mixed
5812
5813       escloc_i=0.0D0
5814
5815       do j=1,3
5816         dersc(j)=0.0D0
5817       enddo
5818
5819       do j=1,nlobit
5820         do k=1,2
5821           z(k)=x(k)-censc(k,j,it)
5822         enddo
5823         z(3)=dwapi
5824         do k=1,3
5825           Axk=0.0D0
5826           do l=1,3
5827             Axk=Axk+gaussc(l,k,j,it)*z(l)
5828           enddo
5829           Ax(k,j)=Axk
5830         enddo
5831         expfac=0.0D0
5832         do k=1,3
5833           expfac=expfac+Ax(k,j)*z(k)
5834         enddo
5835         contr(j)=expfac
5836       enddo ! j
5837
5838 C As in the case of ebend, we want to avoid underflows in exponentiation and
5839 C subsequent NaNs and INFs in energy calculation.
5840 C Find the largest exponent
5841       emin=contr(1)
5842       do j=1,nlobit
5843         if (emin.gt.contr(j)) emin=contr(j)
5844       enddo
5845       emin=0.5D0*emin
5846
5847 C Compute the contribution to SC energy and derivatives
5848
5849       dersc12=0.0d0
5850       do j=1,nlobit
5851         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5852         escloc_i=escloc_i+expfac
5853         do k=1,2
5854           dersc(k)=dersc(k)+Ax(k,j)*expfac
5855         enddo
5856         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5857      &            +gaussc(1,2,j,it))*expfac
5858         dersc(3)=0.0d0
5859       enddo
5860
5861       dersc(1)=dersc(1)/cos(theti)**2
5862       dersc12=dersc12/cos(theti)**2
5863       escloci=-(dlog(escloc_i)-emin)
5864       do j=1,2
5865         dersc(j)=dersc(j)/escloc_i
5866       enddo
5867       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5868       return
5869       end
5870 #else
5871 c----------------------------------------------------------------------------------
5872       subroutine esc(escloc)
5873 C Calculate the local energy of a side chain and its derivatives in the
5874 C corresponding virtual-bond valence angles THETA and the spherical angles
5875 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5876 C added by Urszula Kozlowska. 07/11/2007
5877 C
5878       implicit real*8 (a-h,o-z)
5879       include 'DIMENSIONS'
5880       include 'DIMENSIONS.ZSCOPT'
5881       include 'COMMON.GEO'
5882       include 'COMMON.LOCAL'
5883       include 'COMMON.VAR'
5884       include 'COMMON.SCROT'
5885       include 'COMMON.INTERACT'
5886       include 'COMMON.DERIV'
5887       include 'COMMON.CHAIN'
5888       include 'COMMON.IOUNITS'
5889       include 'COMMON.NAMES'
5890       include 'COMMON.FFIELD'
5891       include 'COMMON.CONTROL'
5892       include 'COMMON.VECTORS'
5893       double precision x_prime(3),y_prime(3),z_prime(3)
5894      &    , sumene,dsc_i,dp2_i,x(65),
5895      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5896      &    de_dxx,de_dyy,de_dzz,de_dt
5897       double precision s1_t,s1_6_t,s2_t,s2_6_t
5898       double precision
5899      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5900      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5901      & dt_dCi(3),dt_dCi1(3)
5902       common /sccalc/ time11,time12,time112,theti,it,nlobit
5903       delta=0.02d0*pi
5904       escloc=0.0D0
5905       do i=loc_start,loc_end
5906         if (itype(i).eq.ntyp1) cycle
5907         costtab(i+1) =dcos(theta(i+1))
5908         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5909         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5910         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5911         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5912         cosfac=dsqrt(cosfac2)
5913         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5914         sinfac=dsqrt(sinfac2)
5915         it=iabs(itype(i))
5916         if (it.eq.10) goto 1
5917 c
5918 C  Compute the axes of tghe local cartesian coordinates system; store in
5919 c   x_prime, y_prime and z_prime
5920 c
5921         do j=1,3
5922           x_prime(j) = 0.00
5923           y_prime(j) = 0.00
5924           z_prime(j) = 0.00
5925         enddo
5926 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5927 C     &   dc_norm(3,i+nres)
5928         do j = 1,3
5929           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5930           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5931         enddo
5932         do j = 1,3
5933           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5934         enddo
5935 c       write (2,*) "i",i
5936 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5937 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5938 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5939 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5940 c      & " xy",scalar(x_prime(1),y_prime(1)),
5941 c      & " xz",scalar(x_prime(1),z_prime(1)),
5942 c      & " yy",scalar(y_prime(1),y_prime(1)),
5943 c      & " yz",scalar(y_prime(1),z_prime(1)),
5944 c      & " zz",scalar(z_prime(1),z_prime(1))
5945 c
5946 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5947 C to local coordinate system. Store in xx, yy, zz.
5948 c
5949         xx=0.0d0
5950         yy=0.0d0
5951         zz=0.0d0
5952         do j = 1,3
5953           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5954           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5955           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5956         enddo
5957
5958         xxtab(i)=xx
5959         yytab(i)=yy
5960         zztab(i)=zz
5961 C
5962 C Compute the energy of the ith side cbain
5963 C
5964 c        write (2,*) "xx",xx," yy",yy," zz",zz
5965         it=iabs(itype(i))
5966         do j = 1,65
5967           x(j) = sc_parmin(j,it)
5968         enddo
5969 #ifdef CHECK_COORD
5970 Cc diagnostics - remove later
5971         xx1 = dcos(alph(2))
5972         yy1 = dsin(alph(2))*dcos(omeg(2))
5973         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5974         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5975      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5976      &    xx1,yy1,zz1
5977 C,"  --- ", xx_w,yy_w,zz_w
5978 c end diagnostics
5979 #endif
5980         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5981      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5982      &   + x(10)*yy*zz
5983         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5984      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5985      & + x(20)*yy*zz
5986         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5987      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5988      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5989      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5990      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5991      &  +x(40)*xx*yy*zz
5992         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5993      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5994      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5995      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5996      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5997      &  +x(60)*xx*yy*zz
5998         dsc_i   = 0.743d0+x(61)
5999         dp2_i   = 1.9d0+x(62)
6000         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6001      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6002         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6003      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6004         s1=(1+x(63))/(0.1d0 + dscp1)
6005         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6006         s2=(1+x(65))/(0.1d0 + dscp2)
6007         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6008         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6009      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6010 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6011 c     &   sumene4,
6012 c     &   dscp1,dscp2,sumene
6013 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6014         escloc = escloc + sumene
6015 c        write (2,*) "escloc",escloc
6016 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6017 c     &  zz,xx,yy
6018         if (.not. calc_grad) goto 1
6019 #ifdef DEBUG
6020 C
6021 C This section to check the numerical derivatives of the energy of ith side
6022 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6023 C #define DEBUG in the code to turn it on.
6024 C
6025         write (2,*) "sumene               =",sumene
6026         aincr=1.0d-7
6027         xxsave=xx
6028         xx=xx+aincr
6029         write (2,*) xx,yy,zz
6030         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6031         de_dxx_num=(sumenep-sumene)/aincr
6032         xx=xxsave
6033         write (2,*) "xx+ sumene from enesc=",sumenep
6034         yysave=yy
6035         yy=yy+aincr
6036         write (2,*) xx,yy,zz
6037         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6038         de_dyy_num=(sumenep-sumene)/aincr
6039         yy=yysave
6040         write (2,*) "yy+ sumene from enesc=",sumenep
6041         zzsave=zz
6042         zz=zz+aincr
6043         write (2,*) xx,yy,zz
6044         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6045         de_dzz_num=(sumenep-sumene)/aincr
6046         zz=zzsave
6047         write (2,*) "zz+ sumene from enesc=",sumenep
6048         costsave=cost2tab(i+1)
6049         sintsave=sint2tab(i+1)
6050         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6051         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6052         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6053         de_dt_num=(sumenep-sumene)/aincr
6054         write (2,*) " t+ sumene from enesc=",sumenep
6055         cost2tab(i+1)=costsave
6056         sint2tab(i+1)=sintsave
6057 C End of diagnostics section.
6058 #endif
6059 C
6060 C Compute the gradient of esc
6061 C
6062         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6063         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6064         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6065         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6066         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6067         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6068         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6069         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6070         pom1=(sumene3*sint2tab(i+1)+sumene1)
6071      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6072         pom2=(sumene4*cost2tab(i+1)+sumene2)
6073      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6074         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6075         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6076      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6077      &  +x(40)*yy*zz
6078         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6079         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6080      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6081      &  +x(60)*yy*zz
6082         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6083      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6084      &        +(pom1+pom2)*pom_dx
6085 #ifdef DEBUG
6086         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6087 #endif
6088 C
6089         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6090         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6091      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6092      &  +x(40)*xx*zz
6093         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6094         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6095      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6096      &  +x(59)*zz**2 +x(60)*xx*zz
6097         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6098      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6099      &        +(pom1-pom2)*pom_dy
6100 #ifdef DEBUG
6101         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6102 #endif
6103 C
6104         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6105      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6106      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6107      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6108      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6109      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6110      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6111      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6112 #ifdef DEBUG
6113         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6114 #endif
6115 C
6116         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6117      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6118      &  +pom1*pom_dt1+pom2*pom_dt2
6119 #ifdef DEBUG
6120         write(2,*), "de_dt = ", de_dt,de_dt_num
6121 #endif
6122 c
6123 C
6124        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6125        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6126        cosfac2xx=cosfac2*xx
6127        sinfac2yy=sinfac2*yy
6128        do k = 1,3
6129          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6130      &      vbld_inv(i+1)
6131          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6132      &      vbld_inv(i)
6133          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6134          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6135 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6136 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6137 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6138 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6139          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6140          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6141          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6142          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6143          dZZ_Ci1(k)=0.0d0
6144          dZZ_Ci(k)=0.0d0
6145          do j=1,3
6146            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6147      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6148            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6149      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6150          enddo
6151
6152          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6153          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6154          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6155 c
6156          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6157          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6158        enddo
6159
6160        do k=1,3
6161          dXX_Ctab(k,i)=dXX_Ci(k)
6162          dXX_C1tab(k,i)=dXX_Ci1(k)
6163          dYY_Ctab(k,i)=dYY_Ci(k)
6164          dYY_C1tab(k,i)=dYY_Ci1(k)
6165          dZZ_Ctab(k,i)=dZZ_Ci(k)
6166          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6167          dXX_XYZtab(k,i)=dXX_XYZ(k)
6168          dYY_XYZtab(k,i)=dYY_XYZ(k)
6169          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6170        enddo
6171
6172        do k = 1,3
6173 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6174 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6175 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6176 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6177 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6178 c     &    dt_dci(k)
6179 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6180 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6181          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6182      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6183          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6184      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6185          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6186      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6187        enddo
6188 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6189 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6190
6191 C to check gradient call subroutine check_grad
6192
6193     1 continue
6194       enddo
6195       return
6196       end
6197 #endif
6198 c------------------------------------------------------------------------------
6199       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6200 C
6201 C This procedure calculates two-body contact function g(rij) and its derivative:
6202 C
6203 C           eps0ij                                     !       x < -1
6204 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6205 C            0                                         !       x > 1
6206 C
6207 C where x=(rij-r0ij)/delta
6208 C
6209 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6210 C
6211       implicit none
6212       double precision rij,r0ij,eps0ij,fcont,fprimcont
6213       double precision x,x2,x4,delta
6214 c     delta=0.02D0*r0ij
6215 c      delta=0.2D0*r0ij
6216       x=(rij-r0ij)/delta
6217       if (x.lt.-1.0D0) then
6218         fcont=eps0ij
6219         fprimcont=0.0D0
6220       else if (x.le.1.0D0) then
6221         x2=x*x
6222         x4=x2*x2
6223         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6224         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6225       else
6226         fcont=0.0D0
6227         fprimcont=0.0D0
6228       endif
6229       return
6230       end
6231 c------------------------------------------------------------------------------
6232       subroutine splinthet(theti,delta,ss,ssder)
6233       implicit real*8 (a-h,o-z)
6234       include 'DIMENSIONS'
6235       include 'DIMENSIONS.ZSCOPT'
6236       include 'COMMON.VAR'
6237       include 'COMMON.GEO'
6238       thetup=pi-delta
6239       thetlow=delta
6240       if (theti.gt.pipol) then
6241         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6242       else
6243         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6244         ssder=-ssder
6245       endif
6246       return
6247       end
6248 c------------------------------------------------------------------------------
6249       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6250       implicit none
6251       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6252       double precision ksi,ksi2,ksi3,a1,a2,a3
6253       a1=fprim0*delta/(f1-f0)
6254       a2=3.0d0-2.0d0*a1
6255       a3=a1-2.0d0
6256       ksi=(x-x0)/delta
6257       ksi2=ksi*ksi
6258       ksi3=ksi2*ksi
6259       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6260       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6261       return
6262       end
6263 c------------------------------------------------------------------------------
6264       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6265       implicit none
6266       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6267       double precision ksi,ksi2,ksi3,a1,a2,a3
6268       ksi=(x-x0)/delta
6269       ksi2=ksi*ksi
6270       ksi3=ksi2*ksi
6271       a1=fprim0x*delta
6272       a2=3*(f1x-f0x)-2*fprim0x*delta
6273       a3=fprim0x*delta-2*(f1x-f0x)
6274       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6275       return
6276       end
6277 C-----------------------------------------------------------------------------
6278 #ifdef CRYST_TOR
6279 C-----------------------------------------------------------------------------
6280       subroutine etor(etors,fact)
6281       implicit real*8 (a-h,o-z)
6282       include 'DIMENSIONS'
6283       include 'DIMENSIONS.ZSCOPT'
6284       include 'COMMON.VAR'
6285       include 'COMMON.GEO'
6286       include 'COMMON.LOCAL'
6287       include 'COMMON.TORSION'
6288       include 'COMMON.INTERACT'
6289       include 'COMMON.DERIV'
6290       include 'COMMON.CHAIN'
6291       include 'COMMON.NAMES'
6292       include 'COMMON.IOUNITS'
6293       include 'COMMON.FFIELD'
6294       include 'COMMON.TORCNSTR'
6295       logical lprn
6296 C Set lprn=.true. for debugging
6297       lprn=.false.
6298 c      lprn=.true.
6299       etors=0.0D0
6300       do i=iphi_start,iphi_end
6301         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6302      &      .or. itype(i).eq.ntyp1) cycle
6303         itori=itortyp(itype(i-2))
6304         itori1=itortyp(itype(i-1))
6305         phii=phi(i)
6306         gloci=0.0D0
6307 C Proline-Proline pair is a special case...
6308         if (itori.eq.3 .and. itori1.eq.3) then
6309           if (phii.gt.-dwapi3) then
6310             cosphi=dcos(3*phii)
6311             fac=1.0D0/(1.0D0-cosphi)
6312             etorsi=v1(1,3,3)*fac
6313             etorsi=etorsi+etorsi
6314             etors=etors+etorsi-v1(1,3,3)
6315             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6316           endif
6317           do j=1,3
6318             v1ij=v1(j+1,itori,itori1)
6319             v2ij=v2(j+1,itori,itori1)
6320             cosphi=dcos(j*phii)
6321             sinphi=dsin(j*phii)
6322             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6323             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6324           enddo
6325         else
6326           do j=1,nterm_old
6327             v1ij=v1(j,itori,itori1)
6328             v2ij=v2(j,itori,itori1)
6329             cosphi=dcos(j*phii)
6330             sinphi=dsin(j*phii)
6331             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6332             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6333           enddo
6334         endif
6335         if (lprn)
6336      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6337      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6338      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6339         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6340 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6341       enddo
6342       return
6343       end
6344 c------------------------------------------------------------------------------
6345 #else
6346       subroutine etor(etors,fact)
6347       implicit real*8 (a-h,o-z)
6348       include 'DIMENSIONS'
6349       include 'DIMENSIONS.ZSCOPT'
6350       include 'COMMON.VAR'
6351       include 'COMMON.GEO'
6352       include 'COMMON.LOCAL'
6353       include 'COMMON.TORSION'
6354       include 'COMMON.INTERACT'
6355       include 'COMMON.DERIV'
6356       include 'COMMON.CHAIN'
6357       include 'COMMON.NAMES'
6358       include 'COMMON.IOUNITS'
6359       include 'COMMON.FFIELD'
6360       include 'COMMON.TORCNSTR'
6361       logical lprn
6362 C Set lprn=.true. for debugging
6363       lprn=.false.
6364 c      lprn=.true.
6365       etors=0.0D0
6366       do i=iphi_start,iphi_end
6367         if (i.le.2) cycle
6368         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6369      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6370 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6371 C     &       .or. itype(i).eq.ntyp1) cycle
6372         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6373          if (iabs(itype(i)).eq.20) then
6374          iblock=2
6375          else
6376          iblock=1
6377          endif
6378         itori=itortyp(itype(i-2))
6379         itori1=itortyp(itype(i-1))
6380         phii=phi(i)
6381         gloci=0.0D0
6382 C Regular cosine and sine terms
6383         do j=1,nterm(itori,itori1,iblock)
6384           v1ij=v1(j,itori,itori1,iblock)
6385           v2ij=v2(j,itori,itori1,iblock)
6386           cosphi=dcos(j*phii)
6387           sinphi=dsin(j*phii)
6388           etors=etors+v1ij*cosphi+v2ij*sinphi
6389           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6390         enddo
6391 C Lorentz terms
6392 C                         v1
6393 C  E = SUM ----------------------------------- - v1
6394 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6395 C
6396         cosphi=dcos(0.5d0*phii)
6397         sinphi=dsin(0.5d0*phii)
6398         do j=1,nlor(itori,itori1,iblock)
6399           vl1ij=vlor1(j,itori,itori1)
6400           vl2ij=vlor2(j,itori,itori1)
6401           vl3ij=vlor3(j,itori,itori1)
6402           pom=vl2ij*cosphi+vl3ij*sinphi
6403           pom1=1.0d0/(pom*pom+1.0d0)
6404           etors=etors+vl1ij*pom1
6405 c          if (energy_dec) etors_ii=etors_ii+
6406 c     &                vl1ij*pom1
6407           pom=-pom*pom1*pom1
6408           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6409         enddo
6410 C Subtract the constant term
6411         etors=etors-v0(itori,itori1,iblock)
6412         if (lprn)
6413      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6414      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6415      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6416         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6417 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6418  1215   continue
6419       enddo
6420       return
6421       end
6422 c----------------------------------------------------------------------------
6423       subroutine etor_d(etors_d,fact2)
6424 C 6/23/01 Compute double torsional energy
6425       implicit real*8 (a-h,o-z)
6426       include 'DIMENSIONS'
6427       include 'DIMENSIONS.ZSCOPT'
6428       include 'COMMON.VAR'
6429       include 'COMMON.GEO'
6430       include 'COMMON.LOCAL'
6431       include 'COMMON.TORSION'
6432       include 'COMMON.INTERACT'
6433       include 'COMMON.DERIV'
6434       include 'COMMON.CHAIN'
6435       include 'COMMON.NAMES'
6436       include 'COMMON.IOUNITS'
6437       include 'COMMON.FFIELD'
6438       include 'COMMON.TORCNSTR'
6439       logical lprn
6440 C Set lprn=.true. for debugging
6441       lprn=.false.
6442 c     lprn=.true.
6443       etors_d=0.0D0
6444       do i=iphi_start,iphi_end-1
6445         if (i.le.3) cycle
6446 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6447 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6448          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6449      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6450      &  (itype(i+1).eq.ntyp1)) cycle
6451         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6452      &     goto 1215
6453         itori=itortyp(itype(i-2))
6454         itori1=itortyp(itype(i-1))
6455         itori2=itortyp(itype(i))
6456         phii=phi(i)
6457         phii1=phi(i+1)
6458         gloci1=0.0D0
6459         gloci2=0.0D0
6460         iblock=1
6461         if (iabs(itype(i+1)).eq.20) iblock=2
6462 C Regular cosine and sine terms
6463         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6464           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6465           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6466           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6467           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6468           cosphi1=dcos(j*phii)
6469           sinphi1=dsin(j*phii)
6470           cosphi2=dcos(j*phii1)
6471           sinphi2=dsin(j*phii1)
6472           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6473      &     v2cij*cosphi2+v2sij*sinphi2
6474           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6475           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6476         enddo
6477         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6478           do l=1,k-1
6479             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6480             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6481             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6482             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6483             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6484             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6485             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6486             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6487             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6488      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6489             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6490      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6491             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6492      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6493           enddo
6494         enddo
6495         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6496         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6497  1215   continue
6498       enddo
6499       return
6500       end
6501 #endif
6502 c---------------------------------------------------------------------------
6503 C The rigorous attempt to derive energy function
6504       subroutine etor_kcc(etors,fact)
6505       implicit real*8 (a-h,o-z)
6506       include 'DIMENSIONS'
6507       include 'DIMENSIONS.ZSCOPT'
6508       include 'COMMON.VAR'
6509       include 'COMMON.GEO'
6510       include 'COMMON.LOCAL'
6511       include 'COMMON.TORSION'
6512       include 'COMMON.INTERACT'
6513       include 'COMMON.DERIV'
6514       include 'COMMON.CHAIN'
6515       include 'COMMON.NAMES'
6516       include 'COMMON.IOUNITS'
6517       include 'COMMON.FFIELD'
6518       include 'COMMON.TORCNSTR'
6519       include 'COMMON.CONTROL'
6520       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6521       logical lprn
6522 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6523 C Set lprn=.true. for debugging
6524       lprn=energy_dec
6525 c     lprn=.true.
6526 C      print *,"wchodze kcc"
6527       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6528       etors=0.0D0
6529       do i=iphi_start,iphi_end
6530 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6531 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6532 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6533 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6534         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6535      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6536         itori=itortyp(itype(i-2))
6537         itori1=itortyp(itype(i-1))
6538         phii=phi(i)
6539         glocig=0.0D0
6540         glocit1=0.0d0
6541         glocit2=0.0d0
6542 C to avoid multiple devision by 2
6543 c        theti22=0.5d0*theta(i)
6544 C theta 12 is the theta_1 /2
6545 C theta 22 is theta_2 /2
6546 c        theti12=0.5d0*theta(i-1)
6547 C and appropriate sinus function
6548         sinthet1=dsin(theta(i-1))
6549         sinthet2=dsin(theta(i))
6550         costhet1=dcos(theta(i-1))
6551         costhet2=dcos(theta(i))
6552 C to speed up lets store its mutliplication
6553         sint1t2=sinthet2*sinthet1
6554         sint1t2n=1.0d0
6555 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6556 C +d_n*sin(n*gamma)) *
6557 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6558 C we have two sum 1) Non-Chebyshev which is with n and gamma
6559         nval=nterm_kcc_Tb(itori,itori1)
6560         c1(0)=0.0d0
6561         c2(0)=0.0d0
6562         c1(1)=1.0d0
6563         c2(1)=1.0d0
6564         do j=2,nval
6565           c1(j)=c1(j-1)*costhet1
6566           c2(j)=c2(j-1)*costhet2
6567         enddo
6568         etori=0.0d0
6569         do j=1,nterm_kcc(itori,itori1)
6570           cosphi=dcos(j*phii)
6571           sinphi=dsin(j*phii)
6572           sint1t2n1=sint1t2n
6573           sint1t2n=sint1t2n*sint1t2
6574           sumvalc=0.0d0
6575           gradvalct1=0.0d0
6576           gradvalct2=0.0d0
6577           do k=1,nval
6578             do l=1,nval
6579               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6580               gradvalct1=gradvalct1+
6581      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6582               gradvalct2=gradvalct2+
6583      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6584             enddo
6585           enddo
6586           gradvalct1=-gradvalct1*sinthet1
6587           gradvalct2=-gradvalct2*sinthet2
6588           sumvals=0.0d0
6589           gradvalst1=0.0d0
6590           gradvalst2=0.0d0
6591           do k=1,nval
6592             do l=1,nval
6593               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6594               gradvalst1=gradvalst1+
6595      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6596               gradvalst2=gradvalst2+
6597      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6598             enddo
6599           enddo
6600           gradvalst1=-gradvalst1*sinthet1
6601           gradvalst2=-gradvalst2*sinthet2
6602           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6603 C glocig is the gradient local i site in gamma
6604           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6605 C now gradient over theta_1
6606           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6607      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6608           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6609      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6610         enddo ! j
6611         etors=etors+etori
6612 C derivative over gamma
6613         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6614 C derivative over theta1
6615         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6616 C now derivative over theta2
6617         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6618         if (lprn) then
6619           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6620      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6621           write (iout,*) "c1",(c1(k),k=0,nval),
6622      &    " c2",(c2(k),k=0,nval)
6623           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6624         endif
6625       enddo
6626       return
6627       end
6628 c---------------------------------------------------------------------------------------------
6629       subroutine etor_constr(edihcnstr)
6630       implicit real*8 (a-h,o-z)
6631       include 'DIMENSIONS'
6632       include 'DIMENSIONS.ZSCOPT'
6633       include 'COMMON.VAR'
6634       include 'COMMON.GEO'
6635       include 'COMMON.LOCAL'
6636       include 'COMMON.TORSION'
6637       include 'COMMON.INTERACT'
6638       include 'COMMON.DERIV'
6639       include 'COMMON.CHAIN'
6640       include 'COMMON.NAMES'
6641       include 'COMMON.IOUNITS'
6642       include 'COMMON.FFIELD'
6643       include 'COMMON.TORCNSTR'
6644       include 'COMMON.CONTROL'
6645 ! 6/20/98 - dihedral angle constraints
6646       edihcnstr=0.0d0
6647 c      do i=1,ndih_constr
6648 c      write (iout,*) "idihconstr_start",idihconstr_start,
6649 c     &  " idihconstr_end",idihconstr_end
6650
6651       if (raw_psipred) then
6652         do i=idihconstr_start,idihconstr_end
6653           itori=idih_constr(i)
6654           phii=phi(itori)
6655           gaudih_i=vpsipred(1,i)
6656           gauder_i=0.0d0
6657           do j=1,2
6658             s = sdihed(j,i)
6659             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6660             dexpcos_i=dexp(-cos_i*cos_i)
6661             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6662             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6663      &            *cos_i*dexpcos_i/s**2
6664           enddo
6665           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6666           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6667           if (energy_dec)
6668      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6669      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6670      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6671      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6672      &     -wdihc*dlog(gaudih_i)
6673         enddo
6674       else
6675
6676       do i=idihconstr_start,idihconstr_end
6677         itori=idih_constr(i)
6678         phii=phi(itori)
6679         difi=pinorm(phii-phi0(i))
6680         if (difi.gt.drange(i)) then
6681           difi=difi-drange(i)
6682           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6683           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6684         else if (difi.lt.-drange(i)) then
6685           difi=difi+drange(i)
6686           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6687           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6688         else
6689           difi=0.0
6690         endif
6691       enddo
6692
6693       endif
6694
6695 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6696       return
6697       end
6698 c----------------------------------------------------------------------------
6699 C The rigorous attempt to derive energy function
6700       subroutine ebend_kcc(etheta)
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       logical lprn
6718       double precision thybt1(maxang_kcc)
6719 C Set lprn=.true. for debugging
6720       lprn=energy_dec
6721 c     lprn=.true.
6722 C      print *,"wchodze kcc"
6723       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6724       etheta=0.0D0
6725       do i=ithet_start,ithet_end
6726 c        print *,i,itype(i-1),itype(i),itype(i-2)
6727         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6728      &  .or.itype(i).eq.ntyp1) cycle
6729         iti=iabs(itortyp(itype(i-1)))
6730         sinthet=dsin(theta(i))
6731         costhet=dcos(theta(i))
6732         do j=1,nbend_kcc_Tb(iti)
6733           thybt1(j)=v1bend_chyb(j,iti)
6734         enddo
6735         sumth1thyb=v1bend_chyb(0,iti)+
6736      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6737         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6738      &    sumth1thyb
6739         ihelp=nbend_kcc_Tb(iti)-1
6740         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6741         etheta=etheta+sumth1thyb
6742 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6743         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6744       enddo
6745       return
6746       end
6747 c-------------------------------------------------------------------------------------
6748       subroutine etheta_constr(ethetacnstr)
6749
6750       implicit real*8 (a-h,o-z)
6751       include 'DIMENSIONS'
6752       include 'DIMENSIONS.ZSCOPT'
6753       include 'COMMON.VAR'
6754       include 'COMMON.GEO'
6755       include 'COMMON.LOCAL'
6756       include 'COMMON.TORSION'
6757       include 'COMMON.INTERACT'
6758       include 'COMMON.DERIV'
6759       include 'COMMON.CHAIN'
6760       include 'COMMON.NAMES'
6761       include 'COMMON.IOUNITS'
6762       include 'COMMON.FFIELD'
6763       include 'COMMON.TORCNSTR'
6764       include 'COMMON.CONTROL'
6765       ethetacnstr=0.0d0
6766 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6767       do i=ithetaconstr_start,ithetaconstr_end
6768         itheta=itheta_constr(i)
6769         thetiii=theta(itheta)
6770         difi=pinorm(thetiii-theta_constr0(i))
6771         if (difi.gt.theta_drange(i)) then
6772           difi=difi-theta_drange(i)
6773           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6774           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6775      &    +for_thet_constr(i)*difi**3
6776         else if (difi.lt.-drange(i)) then
6777           difi=difi+drange(i)
6778           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6779           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6780      &    +for_thet_constr(i)*difi**3
6781         else
6782           difi=0.0
6783         endif
6784        if (energy_dec) then
6785         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6786      &    i,itheta,rad2deg*thetiii,
6787      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6788      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6789      &    gloc(itheta+nphi-2,icg)
6790         endif
6791       enddo
6792       return
6793       end
6794 c------------------------------------------------------------------------------
6795 c------------------------------------------------------------------------------
6796       subroutine eback_sc_corr(esccor)
6797 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6798 c        conformational states; temporarily implemented as differences
6799 c        between UNRES torsional potentials (dependent on three types of
6800 c        residues) and the torsional potentials dependent on all 20 types
6801 c        of residues computed from AM1 energy surfaces of terminally-blocked
6802 c        amino-acid residues.
6803       implicit real*8 (a-h,o-z)
6804       include 'DIMENSIONS'
6805       include 'DIMENSIONS.ZSCOPT'
6806       include 'COMMON.VAR'
6807       include 'COMMON.GEO'
6808       include 'COMMON.LOCAL'
6809       include 'COMMON.TORSION'
6810       include 'COMMON.SCCOR'
6811       include 'COMMON.INTERACT'
6812       include 'COMMON.DERIV'
6813       include 'COMMON.CHAIN'
6814       include 'COMMON.NAMES'
6815       include 'COMMON.IOUNITS'
6816       include 'COMMON.FFIELD'
6817       include 'COMMON.CONTROL'
6818       logical lprn
6819 C Set lprn=.true. for debugging
6820       lprn=.false.
6821 c      lprn=.true.
6822 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6823       esccor=0.0D0
6824       do i=itau_start,itau_end
6825         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6826         esccor_ii=0.0D0
6827         isccori=isccortyp(itype(i-2))
6828         isccori1=isccortyp(itype(i-1))
6829         phii=phi(i)
6830         do intertyp=1,3 !intertyp
6831 cc Added 09 May 2012 (Adasko)
6832 cc  Intertyp means interaction type of backbone mainchain correlation:
6833 c   1 = SC...Ca...Ca...Ca
6834 c   2 = Ca...Ca...Ca...SC
6835 c   3 = SC...Ca...Ca...SCi
6836         gloci=0.0D0
6837         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6838      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6839      &      (itype(i-1).eq.ntyp1)))
6840      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6841      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6842      &     .or.(itype(i).eq.ntyp1)))
6843      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6844      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6845      &      (itype(i-3).eq.ntyp1)))) cycle
6846         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6847         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6848      & cycle
6849        do j=1,nterm_sccor(isccori,isccori1)
6850           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6851           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6852           cosphi=dcos(j*tauangle(intertyp,i))
6853           sinphi=dsin(j*tauangle(intertyp,i))
6854            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6855            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6856          enddo
6857 C      write (iout,*)"EBACK_SC_COR",esccor,i
6858 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6859 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6860 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6861         if (lprn)
6862      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6863      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6864      &  (v1sccor(j,1,itori,itori1),j=1,6)
6865      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6866 c        gsccor_loc(i-3)=gloci
6867        enddo !intertyp
6868       enddo
6869       return
6870       end
6871 #ifdef FOURBODY
6872 c------------------------------------------------------------------------------
6873       subroutine multibody(ecorr)
6874 C This subroutine calculates multi-body contributions to energy following
6875 C the idea of Skolnick et al. If side chains I and J make a contact and
6876 C at the same time side chains I+1 and J+1 make a contact, an extra
6877 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6878       implicit real*8 (a-h,o-z)
6879       include 'DIMENSIONS'
6880       include 'COMMON.IOUNITS'
6881       include 'COMMON.DERIV'
6882       include 'COMMON.INTERACT'
6883       include 'COMMON.CONTACTS'
6884       include 'COMMON.CONTMAT'
6885       include 'COMMON.CORRMAT'
6886       double precision gx(3),gx1(3)
6887       logical lprn
6888
6889 C Set lprn=.true. for debugging
6890       lprn=.false.
6891
6892       if (lprn) then
6893         write (iout,'(a)') 'Contact function values:'
6894         do i=nnt,nct-2
6895           write (iout,'(i2,20(1x,i2,f10.5))')
6896      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6897         enddo
6898       endif
6899       ecorr=0.0D0
6900       do i=nnt,nct
6901         do j=1,3
6902           gradcorr(j,i)=0.0D0
6903           gradxorr(j,i)=0.0D0
6904         enddo
6905       enddo
6906       do i=nnt,nct-2
6907
6908         DO ISHIFT = 3,4
6909
6910         i1=i+ishift
6911         num_conti=num_cont(i)
6912         num_conti1=num_cont(i1)
6913         do jj=1,num_conti
6914           j=jcont(jj,i)
6915           do kk=1,num_conti1
6916             j1=jcont(kk,i1)
6917             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6918 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6919 cd   &                   ' ishift=',ishift
6920 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6921 C The system gains extra energy.
6922               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6923             endif   ! j1==j+-ishift
6924           enddo     ! kk
6925         enddo       ! jj
6926
6927         ENDDO ! ISHIFT
6928
6929       enddo         ! i
6930       return
6931       end
6932 c------------------------------------------------------------------------------
6933       double precision function esccorr(i,j,k,l,jj,kk)
6934       implicit real*8 (a-h,o-z)
6935       include 'DIMENSIONS'
6936       include 'COMMON.IOUNITS'
6937       include 'COMMON.DERIV'
6938       include 'COMMON.INTERACT'
6939       include 'COMMON.CONTACTS'
6940       include 'COMMON.CONTMAT'
6941       include 'COMMON.CORRMAT'
6942       double precision gx(3),gx1(3)
6943       logical lprn
6944       lprn=.false.
6945       eij=facont(jj,i)
6946       ekl=facont(kk,k)
6947 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6948 C Calculate the multi-body contribution to energy.
6949 C Calculate multi-body contributions to the gradient.
6950 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6951 cd   & k,l,(gacont(m,kk,k),m=1,3)
6952       do m=1,3
6953         gx(m) =ekl*gacont(m,jj,i)
6954         gx1(m)=eij*gacont(m,kk,k)
6955         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6956         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6957         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6958         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6959       enddo
6960       do m=i,j-1
6961         do ll=1,3
6962           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6963         enddo
6964       enddo
6965       do m=k,l-1
6966         do ll=1,3
6967           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6968         enddo
6969       enddo
6970       esccorr=-eij*ekl
6971       return
6972       end
6973 c------------------------------------------------------------------------------
6974       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6975 C This subroutine calculates multi-body contributions to hydrogen-bonding
6976       implicit real*8 (a-h,o-z)
6977       include 'DIMENSIONS'
6978       include 'DIMENSIONS.ZSCOPT'
6979       include 'COMMON.IOUNITS'
6980       include 'COMMON.FFIELD'
6981       include 'COMMON.DERIV'
6982       include 'COMMON.INTERACT'
6983       include 'COMMON.CONTACTS'
6984       include 'COMMON.CONTMAT'
6985       include 'COMMON.CORRMAT'
6986       double precision gx(3),gx1(3)
6987       logical lprn,ldone
6988
6989 C Set lprn=.true. for debugging
6990       lprn=.false.
6991       if (lprn) then
6992         write (iout,'(a)') 'Contact function values:'
6993         do i=nnt,nct-2
6994           write (iout,'(2i3,50(1x,i2,f5.2))')
6995      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6996      &    j=1,num_cont_hb(i))
6997         enddo
6998       endif
6999       ecorr=0.0D0
7000 C Remove the loop below after debugging !!!
7001       do i=nnt,nct
7002         do j=1,3
7003           gradcorr(j,i)=0.0D0
7004           gradxorr(j,i)=0.0D0
7005         enddo
7006       enddo
7007 C Calculate the local-electrostatic correlation terms
7008       do i=iatel_s,iatel_e+1
7009         i1=i+1
7010         num_conti=num_cont_hb(i)
7011         num_conti1=num_cont_hb(i+1)
7012         do jj=1,num_conti
7013           j=jcont_hb(jj,i)
7014           do kk=1,num_conti1
7015             j1=jcont_hb(kk,i1)
7016 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7017 c     &         ' jj=',jj,' kk=',kk
7018             if (j1.eq.j+1 .or. j1.eq.j-1) then
7019 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7020 C The system gains extra energy.
7021               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7022               n_corr=n_corr+1
7023             else if (j1.eq.j) then
7024 C Contacts I-J and I-(J+1) occur simultaneously.
7025 C The system loses extra energy.
7026 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7027             endif
7028           enddo ! kk
7029           do kk=1,num_conti
7030             j1=jcont_hb(kk,i)
7031 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7032 c    &         ' jj=',jj,' kk=',kk
7033             if (j1.eq.j+1) then
7034 C Contacts I-J and (I+1)-J occur simultaneously.
7035 C The system loses extra energy.
7036 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7037             endif ! j1==j+1
7038           enddo ! kk
7039         enddo ! jj
7040       enddo ! i
7041       return
7042       end
7043 c------------------------------------------------------------------------------
7044       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7045      &  n_corr1)
7046 C This subroutine calculates multi-body contributions to hydrogen-bonding
7047       implicit real*8 (a-h,o-z)
7048       include 'DIMENSIONS'
7049       include 'DIMENSIONS.ZSCOPT'
7050       include 'COMMON.IOUNITS'
7051 #ifdef MPI
7052       include "mpif.h"
7053 #endif
7054       include 'COMMON.FFIELD'
7055       include 'COMMON.DERIV'
7056       include 'COMMON.LOCAL'
7057       include 'COMMON.INTERACT'
7058       include 'COMMON.CONTACTS'
7059       include 'COMMON.CONTMAT'
7060       include 'COMMON.CORRMAT'
7061       include 'COMMON.CHAIN'
7062       include 'COMMON.CONTROL'
7063       include 'COMMON.SHIELD'
7064       double precision gx(3),gx1(3)
7065       integer num_cont_hb_old(maxres)
7066       logical lprn,ldone
7067       double precision eello4,eello5,eelo6,eello_turn6
7068       external eello4,eello5,eello6,eello_turn6
7069 C Set lprn=.true. for debugging
7070       lprn=.false.
7071       eturn6=0.0d0
7072       if (lprn) then
7073         write (iout,'(a)') 'Contact function values:'
7074         do i=nnt,nct-2
7075           write (iout,'(2i3,50(1x,i2,5f6.3))')
7076      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7077      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7078         enddo
7079       endif
7080       ecorr=0.0D0
7081       ecorr5=0.0d0
7082       ecorr6=0.0d0
7083 C Remove the loop below after debugging !!!
7084       do i=nnt,nct
7085         do j=1,3
7086           gradcorr(j,i)=0.0D0
7087           gradxorr(j,i)=0.0D0
7088         enddo
7089       enddo
7090 C Calculate the dipole-dipole interaction energies
7091       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7092       do i=iatel_s,iatel_e+1
7093         num_conti=num_cont_hb(i)
7094         do jj=1,num_conti
7095           j=jcont_hb(jj,i)
7096 #ifdef MOMENT
7097           call dipole(i,j,jj)
7098 #endif
7099         enddo
7100       enddo
7101       endif
7102 C Calculate the local-electrostatic correlation terms
7103 c                write (iout,*) "gradcorr5 in eello5 before loop"
7104 c                do iii=1,nres
7105 c                  write (iout,'(i5,3f10.5)')
7106 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7107 c                enddo
7108       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7109 c        write (iout,*) "corr loop i",i
7110         i1=i+1
7111         num_conti=num_cont_hb(i)
7112         num_conti1=num_cont_hb(i+1)
7113         do jj=1,num_conti
7114           j=jcont_hb(jj,i)
7115           jp=iabs(j)
7116           do kk=1,num_conti1
7117             j1=jcont_hb(kk,i1)
7118             jp1=iabs(j1)
7119 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7120 c     &         ' jj=',jj,' kk=',kk
7121 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7122             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7123      &          .or. j.lt.0 .and. j1.gt.0) .and.
7124      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7125 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7126 C The system gains extra energy.
7127               n_corr=n_corr+1
7128               sqd1=dsqrt(d_cont(jj,i))
7129               sqd2=dsqrt(d_cont(kk,i1))
7130               sred_geom = sqd1*sqd2
7131               IF (sred_geom.lt.cutoff_corr) THEN
7132                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7133      &            ekont,fprimcont)
7134 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7135 cd     &         ' jj=',jj,' kk=',kk
7136                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7137                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7138                 do l=1,3
7139                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7140                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7141                 enddo
7142                 n_corr1=n_corr1+1
7143 cd               write (iout,*) 'sred_geom=',sred_geom,
7144 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7145 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7146 cd               write (iout,*) "g_contij",g_contij
7147 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7148 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7149                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7150                 if (wcorr4.gt.0.0d0)
7151      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7152 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7153                   if (energy_dec.and.wcorr4.gt.0.0d0)
7154      1                 write (iout,'(a6,4i5,0pf7.3)')
7155      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7156 c                write (iout,*) "gradcorr5 before eello5"
7157 c                do iii=1,nres
7158 c                  write (iout,'(i5,3f10.5)')
7159 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7160 c                enddo
7161                 if (wcorr5.gt.0.0d0)
7162      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7163 c                write (iout,*) "gradcorr5 after eello5"
7164 c                do iii=1,nres
7165 c                  write (iout,'(i5,3f10.5)')
7166 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7167 c                enddo
7168                   if (energy_dec.and.wcorr5.gt.0.0d0)
7169      1                 write (iout,'(a6,4i5,0pf7.3)')
7170      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7171 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7172 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7173                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7174      &               .or. wturn6.eq.0.0d0))then
7175 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7176                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7177                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7178      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7179 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7180 cd     &            'ecorr6=',ecorr6
7181 cd                write (iout,'(4e15.5)') sred_geom,
7182 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7183 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7184 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7185                 else if (wturn6.gt.0.0d0
7186      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7187 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7188                   eturn6=eturn6+eello_turn6(i,jj,kk)
7189                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7190      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7191 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7192                 endif
7193               ENDIF
7194 1111          continue
7195             endif
7196           enddo ! kk
7197         enddo ! jj
7198       enddo ! i
7199       do i=1,nres
7200         num_cont_hb(i)=num_cont_hb_old(i)
7201       enddo
7202 c                write (iout,*) "gradcorr5 in eello5"
7203 c                do iii=1,nres
7204 c                  write (iout,'(i5,3f10.5)')
7205 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7206 c                enddo
7207       return
7208       end
7209 c------------------------------------------------------------------------------
7210       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7211       implicit real*8 (a-h,o-z)
7212       include 'DIMENSIONS'
7213       include 'DIMENSIONS.ZSCOPT'
7214       include 'COMMON.IOUNITS'
7215       include 'COMMON.DERIV'
7216       include 'COMMON.INTERACT'
7217       include 'COMMON.CONTACTS'
7218       include 'COMMON.CONTMAT'
7219       include 'COMMON.CORRMAT'
7220       include 'COMMON.SHIELD'
7221       include 'COMMON.CONTROL'
7222       double precision gx(3),gx1(3)
7223       logical lprn
7224       lprn=.false.
7225 C      print *,"wchodze",fac_shield(i),shield_mode
7226       eij=facont_hb(jj,i)
7227       ekl=facont_hb(kk,k)
7228       ees0pij=ees0p(jj,i)
7229       ees0pkl=ees0p(kk,k)
7230       ees0mij=ees0m(jj,i)
7231       ees0mkl=ees0m(kk,k)
7232       ekont=eij*ekl
7233       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7234 C*
7235 C     & fac_shield(i)**2*fac_shield(j)**2
7236 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7237 C Following 4 lines for diagnostics.
7238 cd    ees0pkl=0.0D0
7239 cd    ees0pij=1.0D0
7240 cd    ees0mkl=0.0D0
7241 cd    ees0mij=1.0D0
7242 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7243 c     & 'Contacts ',i,j,
7244 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7245 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7246 c     & 'gradcorr_long'
7247 C Calculate the multi-body contribution to energy.
7248 C      ecorr=ecorr+ekont*ees
7249 C Calculate multi-body contributions to the gradient.
7250       coeffpees0pij=coeffp*ees0pij
7251       coeffmees0mij=coeffm*ees0mij
7252       coeffpees0pkl=coeffp*ees0pkl
7253       coeffmees0mkl=coeffm*ees0mkl
7254       do ll=1,3
7255 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7256         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7257      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7258      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7259         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7260      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7261      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7262 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7263         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7264      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7265      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7266         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7267      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7268      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7269         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7270      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7271      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7272         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7273         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7274         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7275      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7276      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7277         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7278         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7279 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7280       enddo
7281 c      write (iout,*)
7282 cgrad      do m=i+1,j-1
7283 cgrad        do ll=1,3
7284 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7285 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7286 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7287 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7288 cgrad        enddo
7289 cgrad      enddo
7290 cgrad      do m=k+1,l-1
7291 cgrad        do ll=1,3
7292 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7293 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7294 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7295 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7296 cgrad        enddo
7297 cgrad      enddo
7298 c      write (iout,*) "ehbcorr",ekont*ees
7299 C      print *,ekont,ees,i,k
7300       ehbcorr=ekont*ees
7301 C now gradient over shielding
7302 C      return
7303       if (shield_mode.gt.0) then
7304        j=ees0plist(jj,i)
7305        l=ees0plist(kk,k)
7306 C        print *,i,j,fac_shield(i),fac_shield(j),
7307 C     &fac_shield(k),fac_shield(l)
7308         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7309      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7310           do ilist=1,ishield_list(i)
7311            iresshield=shield_list(ilist,i)
7312            do m=1,3
7313            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7314 C     &      *2.0
7315            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7316      &              rlocshield
7317      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7318             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7319      &+rlocshield
7320            enddo
7321           enddo
7322           do ilist=1,ishield_list(j)
7323            iresshield=shield_list(ilist,j)
7324            do m=1,3
7325            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7326 C     &     *2.0
7327            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7328      &              rlocshield
7329      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7330            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7331      &     +rlocshield
7332            enddo
7333           enddo
7334
7335           do ilist=1,ishield_list(k)
7336            iresshield=shield_list(ilist,k)
7337            do m=1,3
7338            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7339 C     &     *2.0
7340            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7341      &              rlocshield
7342      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7343            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7344      &     +rlocshield
7345            enddo
7346           enddo
7347           do ilist=1,ishield_list(l)
7348            iresshield=shield_list(ilist,l)
7349            do m=1,3
7350            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7351 C     &     *2.0
7352            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7353      &              rlocshield
7354      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7355            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7356      &     +rlocshield
7357            enddo
7358           enddo
7359 C          print *,gshieldx(m,iresshield)
7360           do m=1,3
7361             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7362      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7363             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7364      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7365             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7366      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7367             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7368      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7369
7370             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7371      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7372             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7373      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7374             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7375      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7376             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7377      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7378
7379            enddo
7380       endif
7381       endif
7382       return
7383       end
7384 #ifdef MOMENT
7385 C---------------------------------------------------------------------------
7386       subroutine dipole(i,j,jj)
7387       implicit real*8 (a-h,o-z)
7388       include 'DIMENSIONS'
7389       include 'DIMENSIONS.ZSCOPT'
7390       include 'COMMON.IOUNITS'
7391       include 'COMMON.CHAIN'
7392       include 'COMMON.FFIELD'
7393       include 'COMMON.DERIV'
7394       include 'COMMON.INTERACT'
7395       include 'COMMON.CONTACTS'
7396       include 'COMMON.CONTMAT'
7397       include 'COMMON.CORRMAT'
7398       include 'COMMON.TORSION'
7399       include 'COMMON.VAR'
7400       include 'COMMON.GEO'
7401       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7402      &  auxmat(2,2)
7403       iti1 = itortyp(itype(i+1))
7404       if (j.lt.nres-1) then
7405         itj1 = itype2loc(itype(j+1))
7406       else
7407         itj1=nloctyp
7408       endif
7409       do iii=1,2
7410         dipi(iii,1)=Ub2(iii,i)
7411         dipderi(iii)=Ub2der(iii,i)
7412         dipi(iii,2)=b1(iii,i+1)
7413         dipj(iii,1)=Ub2(iii,j)
7414         dipderj(iii)=Ub2der(iii,j)
7415         dipj(iii,2)=b1(iii,j+1)
7416       enddo
7417       kkk=0
7418       do iii=1,2
7419         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7420         do jjj=1,2
7421           kkk=kkk+1
7422           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7423         enddo
7424       enddo
7425       do kkk=1,5
7426         do lll=1,3
7427           mmm=0
7428           do iii=1,2
7429             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7430      &        auxvec(1))
7431             do jjj=1,2
7432               mmm=mmm+1
7433               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7434             enddo
7435           enddo
7436         enddo
7437       enddo
7438       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7439       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7440       do iii=1,2
7441         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7442       enddo
7443       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7444       do iii=1,2
7445         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7446       enddo
7447       return
7448       end
7449 #endif
7450 C---------------------------------------------------------------------------
7451       subroutine calc_eello(i,j,k,l,jj,kk)
7452 C
7453 C This subroutine computes matrices and vectors needed to calculate
7454 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7455 C
7456       implicit real*8 (a-h,o-z)
7457       include 'DIMENSIONS'
7458       include 'DIMENSIONS.ZSCOPT'
7459       include 'COMMON.IOUNITS'
7460       include 'COMMON.CHAIN'
7461       include 'COMMON.DERIV'
7462       include 'COMMON.INTERACT'
7463       include 'COMMON.CONTACTS'
7464       include 'COMMON.CONTMAT'
7465       include 'COMMON.CORRMAT'
7466       include 'COMMON.TORSION'
7467       include 'COMMON.VAR'
7468       include 'COMMON.GEO'
7469       include 'COMMON.FFIELD'
7470       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7471      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7472       logical lprn
7473       common /kutas/ lprn
7474 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7475 cd     & ' jj=',jj,' kk=',kk
7476 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7477 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7478 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7479       do iii=1,2
7480         do jjj=1,2
7481           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7482           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7483         enddo
7484       enddo
7485       call transpose2(aa1(1,1),aa1t(1,1))
7486       call transpose2(aa2(1,1),aa2t(1,1))
7487       do kkk=1,5
7488         do lll=1,3
7489           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7490      &      aa1tder(1,1,lll,kkk))
7491           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7492      &      aa2tder(1,1,lll,kkk))
7493         enddo
7494       enddo
7495       if (l.eq.j+1) then
7496 C parallel orientation of the two CA-CA-CA frames.
7497         if (i.gt.1) then
7498           iti=itype2loc(itype(i))
7499         else
7500           iti=nloctyp
7501         endif
7502         itk1=itype2loc(itype(k+1))
7503         itj=itype2loc(itype(j))
7504         if (l.lt.nres-1) then
7505           itl1=itype2loc(itype(l+1))
7506         else
7507           itl1=nloctyp
7508         endif
7509 C A1 kernel(j+1) A2T
7510 cd        do iii=1,2
7511 cd          write (iout,'(3f10.5,5x,3f10.5)')
7512 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7513 cd        enddo
7514         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7515      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7516      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7517 C Following matrices are needed only for 6-th order cumulants
7518         IF (wcorr6.gt.0.0d0) THEN
7519         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7520      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7521      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7522         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7523      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7524      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7525      &   ADtEAderx(1,1,1,1,1,1))
7526         lprn=.false.
7527         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7528      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7529      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7530      &   ADtEA1derx(1,1,1,1,1,1))
7531         ENDIF
7532 C End 6-th order cumulants
7533 cd        lprn=.false.
7534 cd        if (lprn) then
7535 cd        write (2,*) 'In calc_eello6'
7536 cd        do iii=1,2
7537 cd          write (2,*) 'iii=',iii
7538 cd          do kkk=1,5
7539 cd            write (2,*) 'kkk=',kkk
7540 cd            do jjj=1,2
7541 cd              write (2,'(3(2f10.5),5x)')
7542 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7543 cd            enddo
7544 cd          enddo
7545 cd        enddo
7546 cd        endif
7547         call transpose2(EUgder(1,1,k),auxmat(1,1))
7548         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7549         call transpose2(EUg(1,1,k),auxmat(1,1))
7550         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7551         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7552         do iii=1,2
7553           do kkk=1,5
7554             do lll=1,3
7555               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7556      &          EAEAderx(1,1,lll,kkk,iii,1))
7557             enddo
7558           enddo
7559         enddo
7560 C A1T kernel(i+1) A2
7561         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7562      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7563      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7564 C Following matrices are needed only for 6-th order cumulants
7565         IF (wcorr6.gt.0.0d0) THEN
7566         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7567      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7568      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7569         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7570      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7571      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7572      &   ADtEAderx(1,1,1,1,1,2))
7573         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7574      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7575      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7576      &   ADtEA1derx(1,1,1,1,1,2))
7577         ENDIF
7578 C End 6-th order cumulants
7579         call transpose2(EUgder(1,1,l),auxmat(1,1))
7580         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7581         call transpose2(EUg(1,1,l),auxmat(1,1))
7582         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7583         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7584         do iii=1,2
7585           do kkk=1,5
7586             do lll=1,3
7587               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7588      &          EAEAderx(1,1,lll,kkk,iii,2))
7589             enddo
7590           enddo
7591         enddo
7592 C AEAb1 and AEAb2
7593 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7594 C They are needed only when the fifth- or the sixth-order cumulants are
7595 C indluded.
7596         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7597         call transpose2(AEA(1,1,1),auxmat(1,1))
7598         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7599         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7600         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7601         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7602         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7603         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7604         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7605         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7606         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7607         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7608         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7609         call transpose2(AEA(1,1,2),auxmat(1,1))
7610         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7611         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7612         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7613         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7614         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7615         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7616         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7617         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7618         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7619         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7620         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7621 C Calculate the Cartesian derivatives of the vectors.
7622         do iii=1,2
7623           do kkk=1,5
7624             do lll=1,3
7625               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7626               call matvec2(auxmat(1,1),b1(1,i),
7627      &          AEAb1derx(1,lll,kkk,iii,1,1))
7628               call matvec2(auxmat(1,1),Ub2(1,i),
7629      &          AEAb2derx(1,lll,kkk,iii,1,1))
7630               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7631      &          AEAb1derx(1,lll,kkk,iii,2,1))
7632               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7633      &          AEAb2derx(1,lll,kkk,iii,2,1))
7634               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7635               call matvec2(auxmat(1,1),b1(1,j),
7636      &          AEAb1derx(1,lll,kkk,iii,1,2))
7637               call matvec2(auxmat(1,1),Ub2(1,j),
7638      &          AEAb2derx(1,lll,kkk,iii,1,2))
7639               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7640      &          AEAb1derx(1,lll,kkk,iii,2,2))
7641               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7642      &          AEAb2derx(1,lll,kkk,iii,2,2))
7643             enddo
7644           enddo
7645         enddo
7646         ENDIF
7647 C End vectors
7648       else
7649 C Antiparallel orientation of the two CA-CA-CA frames.
7650         if (i.gt.1) then
7651           iti=itype2loc(itype(i))
7652         else
7653           iti=nloctyp
7654         endif
7655         itk1=itype2loc(itype(k+1))
7656         itl=itype2loc(itype(l))
7657         itj=itype2loc(itype(j))
7658         if (j.lt.nres-1) then
7659           itj1=itype2loc(itype(j+1))
7660         else
7661           itj1=nloctyp
7662         endif
7663 C A2 kernel(j-1)T A1T
7664         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7665      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7666      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7667 C Following matrices are needed only for 6-th order cumulants
7668         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7669      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7670         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7671      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7672      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7673         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7674      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7675      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7676      &   ADtEAderx(1,1,1,1,1,1))
7677         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7678      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7679      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7680      &   ADtEA1derx(1,1,1,1,1,1))
7681         ENDIF
7682 C End 6-th order cumulants
7683         call transpose2(EUgder(1,1,k),auxmat(1,1))
7684         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7685         call transpose2(EUg(1,1,k),auxmat(1,1))
7686         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7687         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7688         do iii=1,2
7689           do kkk=1,5
7690             do lll=1,3
7691               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7692      &          EAEAderx(1,1,lll,kkk,iii,1))
7693             enddo
7694           enddo
7695         enddo
7696 C A2T kernel(i+1)T A1
7697         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7698      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7699      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7700 C Following matrices are needed only for 6-th order cumulants
7701         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7702      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7703         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7704      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7705      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7706         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7707      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7708      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7709      &   ADtEAderx(1,1,1,1,1,2))
7710         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7711      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7712      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7713      &   ADtEA1derx(1,1,1,1,1,2))
7714         ENDIF
7715 C End 6-th order cumulants
7716         call transpose2(EUgder(1,1,j),auxmat(1,1))
7717         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7718         call transpose2(EUg(1,1,j),auxmat(1,1))
7719         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7720         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7721         do iii=1,2
7722           do kkk=1,5
7723             do lll=1,3
7724               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7725      &          EAEAderx(1,1,lll,kkk,iii,2))
7726             enddo
7727           enddo
7728         enddo
7729 C AEAb1 and AEAb2
7730 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7731 C They are needed only when the fifth- or the sixth-order cumulants are
7732 C indluded.
7733         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7734      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7735         call transpose2(AEA(1,1,1),auxmat(1,1))
7736         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7737         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7738         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7739         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7740         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7741         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7742         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7743         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7744         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7745         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7746         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7747         call transpose2(AEA(1,1,2),auxmat(1,1))
7748         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7749         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7750         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7751         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7752         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7753         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7754         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7755         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7756         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7757         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7758         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7759 C Calculate the Cartesian derivatives of the vectors.
7760         do iii=1,2
7761           do kkk=1,5
7762             do lll=1,3
7763               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7764               call matvec2(auxmat(1,1),b1(1,i),
7765      &          AEAb1derx(1,lll,kkk,iii,1,1))
7766               call matvec2(auxmat(1,1),Ub2(1,i),
7767      &          AEAb2derx(1,lll,kkk,iii,1,1))
7768               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7769      &          AEAb1derx(1,lll,kkk,iii,2,1))
7770               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7771      &          AEAb2derx(1,lll,kkk,iii,2,1))
7772               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7773               call matvec2(auxmat(1,1),b1(1,l),
7774      &          AEAb1derx(1,lll,kkk,iii,1,2))
7775               call matvec2(auxmat(1,1),Ub2(1,l),
7776      &          AEAb2derx(1,lll,kkk,iii,1,2))
7777               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7778      &          AEAb1derx(1,lll,kkk,iii,2,2))
7779               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7780      &          AEAb2derx(1,lll,kkk,iii,2,2))
7781             enddo
7782           enddo
7783         enddo
7784         ENDIF
7785 C End vectors
7786       endif
7787       return
7788       end
7789 C---------------------------------------------------------------------------
7790       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7791      &  KK,KKderg,AKA,AKAderg,AKAderx)
7792       implicit none
7793       integer nderg
7794       logical transp
7795       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7796      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7797      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7798       integer iii,kkk,lll
7799       integer jjj,mmm
7800       logical lprn
7801       common /kutas/ lprn
7802       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7803       do iii=1,nderg
7804         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7805      &    AKAderg(1,1,iii))
7806       enddo
7807 cd      if (lprn) write (2,*) 'In kernel'
7808       do kkk=1,5
7809 cd        if (lprn) write (2,*) 'kkk=',kkk
7810         do lll=1,3
7811           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7812      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7813 cd          if (lprn) then
7814 cd            write (2,*) 'lll=',lll
7815 cd            write (2,*) 'iii=1'
7816 cd            do jjj=1,2
7817 cd              write (2,'(3(2f10.5),5x)')
7818 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7819 cd            enddo
7820 cd          endif
7821           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7822      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7823 cd          if (lprn) then
7824 cd            write (2,*) 'lll=',lll
7825 cd            write (2,*) 'iii=2'
7826 cd            do jjj=1,2
7827 cd              write (2,'(3(2f10.5),5x)')
7828 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7829 cd            enddo
7830 cd          endif
7831         enddo
7832       enddo
7833       return
7834       end
7835 C---------------------------------------------------------------------------
7836       double precision function eello4(i,j,k,l,jj,kk)
7837       implicit real*8 (a-h,o-z)
7838       include 'DIMENSIONS'
7839       include 'DIMENSIONS.ZSCOPT'
7840       include 'COMMON.IOUNITS'
7841       include 'COMMON.CHAIN'
7842       include 'COMMON.DERIV'
7843       include 'COMMON.INTERACT'
7844       include 'COMMON.CONTACTS'
7845       include 'COMMON.CONTMAT'
7846       include 'COMMON.CORRMAT'
7847       include 'COMMON.TORSION'
7848       include 'COMMON.VAR'
7849       include 'COMMON.GEO'
7850       double precision pizda(2,2),ggg1(3),ggg2(3)
7851 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7852 cd        eello4=0.0d0
7853 cd        return
7854 cd      endif
7855 cd      print *,'eello4:',i,j,k,l,jj,kk
7856 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7857 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7858 cold      eij=facont_hb(jj,i)
7859 cold      ekl=facont_hb(kk,k)
7860 cold      ekont=eij*ekl
7861       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7862       if (calc_grad) then
7863 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7864       gcorr_loc(k-1)=gcorr_loc(k-1)
7865      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7866       if (l.eq.j+1) then
7867         gcorr_loc(l-1)=gcorr_loc(l-1)
7868      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7869       else
7870         gcorr_loc(j-1)=gcorr_loc(j-1)
7871      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7872       endif
7873       do iii=1,2
7874         do kkk=1,5
7875           do lll=1,3
7876             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7877      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7878 cd            derx(lll,kkk,iii)=0.0d0
7879           enddo
7880         enddo
7881       enddo
7882 cd      gcorr_loc(l-1)=0.0d0
7883 cd      gcorr_loc(j-1)=0.0d0
7884 cd      gcorr_loc(k-1)=0.0d0
7885 cd      eel4=1.0d0
7886 cd      write (iout,*)'Contacts have occurred for peptide groups',
7887 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7888 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7889       if (j.lt.nres-1) then
7890         j1=j+1
7891         j2=j-1
7892       else
7893         j1=j-1
7894         j2=j-2
7895       endif
7896       if (l.lt.nres-1) then
7897         l1=l+1
7898         l2=l-1
7899       else
7900         l1=l-1
7901         l2=l-2
7902       endif
7903       do ll=1,3
7904 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7905 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7906         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7907         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7908 cgrad        ghalf=0.5d0*ggg1(ll)
7909         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7910         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7911         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7912         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7913         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7914         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7915 cgrad        ghalf=0.5d0*ggg2(ll)
7916         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7917         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7918         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7919         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7920         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7921         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7922       enddo
7923 cgrad      do m=i+1,j-1
7924 cgrad        do ll=1,3
7925 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7926 cgrad        enddo
7927 cgrad      enddo
7928 cgrad      do m=k+1,l-1
7929 cgrad        do ll=1,3
7930 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7931 cgrad        enddo
7932 cgrad      enddo
7933 cgrad      do m=i+2,j2
7934 cgrad        do ll=1,3
7935 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7936 cgrad        enddo
7937 cgrad      enddo
7938 cgrad      do m=k+2,l2
7939 cgrad        do ll=1,3
7940 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7941 cgrad        enddo
7942 cgrad      enddo
7943 cd      do iii=1,nres-3
7944 cd        write (2,*) iii,gcorr_loc(iii)
7945 cd      enddo
7946       endif ! calc_grad
7947       eello4=ekont*eel4
7948 cd      write (2,*) 'ekont',ekont
7949 cd      write (iout,*) 'eello4',ekont*eel4
7950       return
7951       end
7952 C---------------------------------------------------------------------------
7953       double precision function eello5(i,j,k,l,jj,kk)
7954       implicit real*8 (a-h,o-z)
7955       include 'DIMENSIONS'
7956       include 'DIMENSIONS.ZSCOPT'
7957       include 'COMMON.IOUNITS'
7958       include 'COMMON.CHAIN'
7959       include 'COMMON.DERIV'
7960       include 'COMMON.INTERACT'
7961       include 'COMMON.CONTACTS'
7962       include 'COMMON.CONTMAT'
7963       include 'COMMON.CORRMAT'
7964       include 'COMMON.TORSION'
7965       include 'COMMON.VAR'
7966       include 'COMMON.GEO'
7967       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7968       double precision ggg1(3),ggg2(3)
7969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7970 C                                                                              C
7971 C                            Parallel chains                                   C
7972 C                                                                              C
7973 C          o             o                   o             o                   C
7974 C         /l\           / \             \   / \           / \   /              C
7975 C        /   \         /   \             \ /   \         /   \ /               C
7976 C       j| o |l1       | o |              o| o |         | o |o                C
7977 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7978 C      \i/   \         /   \ /             /   \         /   \                 C
7979 C       o    k1             o                                                  C
7980 C         (I)          (II)                (III)          (IV)                 C
7981 C                                                                              C
7982 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7983 C                                                                              C
7984 C                            Antiparallel chains                               C
7985 C                                                                              C
7986 C          o             o                   o             o                   C
7987 C         /j\           / \             \   / \           / \   /              C
7988 C        /   \         /   \             \ /   \         /   \ /               C
7989 C      j1| o |l        | o |              o| o |         | o |o                C
7990 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7991 C      \i/   \         /   \ /             /   \         /   \                 C
7992 C       o     k1            o                                                  C
7993 C         (I)          (II)                (III)          (IV)                 C
7994 C                                                                              C
7995 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7996 C                                                                              C
7997 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7998 C                                                                              C
7999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8000 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8001 cd        eello5=0.0d0
8002 cd        return
8003 cd      endif
8004 cd      write (iout,*)
8005 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8006 cd     &   ' and',k,l
8007       itk=itype2loc(itype(k))
8008       itl=itype2loc(itype(l))
8009       itj=itype2loc(itype(j))
8010       eello5_1=0.0d0
8011       eello5_2=0.0d0
8012       eello5_3=0.0d0
8013       eello5_4=0.0d0
8014 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8015 cd     &   eel5_3_num,eel5_4_num)
8016       do iii=1,2
8017         do kkk=1,5
8018           do lll=1,3
8019             derx(lll,kkk,iii)=0.0d0
8020           enddo
8021         enddo
8022       enddo
8023 cd      eij=facont_hb(jj,i)
8024 cd      ekl=facont_hb(kk,k)
8025 cd      ekont=eij*ekl
8026 cd      write (iout,*)'Contacts have occurred for peptide groups',
8027 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8028 cd      goto 1111
8029 C Contribution from the graph I.
8030 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8031 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8032       call transpose2(EUg(1,1,k),auxmat(1,1))
8033       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8034       vv(1)=pizda(1,1)-pizda(2,2)
8035       vv(2)=pizda(1,2)+pizda(2,1)
8036       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8037      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8038       if (calc_grad) then
8039 C Explicit gradient in virtual-dihedral angles.
8040       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8041      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8042      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8043       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8044       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8045       vv(1)=pizda(1,1)-pizda(2,2)
8046       vv(2)=pizda(1,2)+pizda(2,1)
8047       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8048      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8049      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8050       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8051       vv(1)=pizda(1,1)-pizda(2,2)
8052       vv(2)=pizda(1,2)+pizda(2,1)
8053       if (l.eq.j+1) then
8054         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8055      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8056      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8057       else
8058         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8059      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8060      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8061       endif
8062 C Cartesian gradient
8063       do iii=1,2
8064         do kkk=1,5
8065           do lll=1,3
8066             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8067      &        pizda(1,1))
8068             vv(1)=pizda(1,1)-pizda(2,2)
8069             vv(2)=pizda(1,2)+pizda(2,1)
8070             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8071      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8072      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8073           enddo
8074         enddo
8075       enddo
8076       endif ! calc_grad
8077 c      goto 1112
8078 c1111  continue
8079 C Contribution from graph II
8080       call transpose2(EE(1,1,k),auxmat(1,1))
8081       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8082       vv(1)=pizda(1,1)+pizda(2,2)
8083       vv(2)=pizda(2,1)-pizda(1,2)
8084       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8085      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8086       if (calc_grad) then
8087 C Explicit gradient in virtual-dihedral angles.
8088       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8089      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8090       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8091       vv(1)=pizda(1,1)+pizda(2,2)
8092       vv(2)=pizda(2,1)-pizda(1,2)
8093       if (l.eq.j+1) then
8094         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8095      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8096      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8097       else
8098         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8099      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8100      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8101       endif
8102 C Cartesian gradient
8103       do iii=1,2
8104         do kkk=1,5
8105           do lll=1,3
8106             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8107      &        pizda(1,1))
8108             vv(1)=pizda(1,1)+pizda(2,2)
8109             vv(2)=pizda(2,1)-pizda(1,2)
8110             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8111      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8112      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8113           enddo
8114         enddo
8115       enddo
8116       endif ! calc_grad
8117 cd      goto 1112
8118 cd1111  continue
8119       if (l.eq.j+1) then
8120 cd        goto 1110
8121 C Parallel orientation
8122 C Contribution from graph III
8123         call transpose2(EUg(1,1,l),auxmat(1,1))
8124         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8125         vv(1)=pizda(1,1)-pizda(2,2)
8126         vv(2)=pizda(1,2)+pizda(2,1)
8127         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8128      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8129         if (calc_grad) then
8130 C Explicit gradient in virtual-dihedral angles.
8131         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8132      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8133      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8134         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8135         vv(1)=pizda(1,1)-pizda(2,2)
8136         vv(2)=pizda(1,2)+pizda(2,1)
8137         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8138      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8139      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8140         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8141         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8142         vv(1)=pizda(1,1)-pizda(2,2)
8143         vv(2)=pizda(1,2)+pizda(2,1)
8144         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8145      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8146      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8147 C Cartesian gradient
8148         do iii=1,2
8149           do kkk=1,5
8150             do lll=1,3
8151               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8152      &          pizda(1,1))
8153               vv(1)=pizda(1,1)-pizda(2,2)
8154               vv(2)=pizda(1,2)+pizda(2,1)
8155               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8156      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8157      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8158             enddo
8159           enddo
8160         enddo
8161 cd        goto 1112
8162 C Contribution from graph IV
8163 cd1110    continue
8164         call transpose2(EE(1,1,l),auxmat(1,1))
8165         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8166         vv(1)=pizda(1,1)+pizda(2,2)
8167         vv(2)=pizda(2,1)-pizda(1,2)
8168         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8169      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8170 C Explicit gradient in virtual-dihedral angles.
8171         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8172      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8173         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8174         vv(1)=pizda(1,1)+pizda(2,2)
8175         vv(2)=pizda(2,1)-pizda(1,2)
8176         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8177      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8178      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8179 C Cartesian gradient
8180         do iii=1,2
8181           do kkk=1,5
8182             do lll=1,3
8183               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8184      &          pizda(1,1))
8185               vv(1)=pizda(1,1)+pizda(2,2)
8186               vv(2)=pizda(2,1)-pizda(1,2)
8187               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8188      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8189      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8190             enddo
8191           enddo
8192         enddo
8193         endif ! calc_grad
8194       else
8195 C Antiparallel orientation
8196 C Contribution from graph III
8197 c        goto 1110
8198         call transpose2(EUg(1,1,j),auxmat(1,1))
8199         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8200         vv(1)=pizda(1,1)-pizda(2,2)
8201         vv(2)=pizda(1,2)+pizda(2,1)
8202         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8203      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8204         if (calc_grad) then
8205 C Explicit gradient in virtual-dihedral angles.
8206         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8207      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8208      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8209         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8210         vv(1)=pizda(1,1)-pizda(2,2)
8211         vv(2)=pizda(1,2)+pizda(2,1)
8212         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8213      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8214      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8215         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8216         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8217         vv(1)=pizda(1,1)-pizda(2,2)
8218         vv(2)=pizda(1,2)+pizda(2,1)
8219         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8220      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8221      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8222 C Cartesian gradient
8223         do iii=1,2
8224           do kkk=1,5
8225             do lll=1,3
8226               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8227      &          pizda(1,1))
8228               vv(1)=pizda(1,1)-pizda(2,2)
8229               vv(2)=pizda(1,2)+pizda(2,1)
8230               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8231      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8232      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8233             enddo
8234           enddo
8235         enddo
8236         endif ! calc_grad
8237 cd        goto 1112
8238 C Contribution from graph IV
8239 1110    continue
8240         call transpose2(EE(1,1,j),auxmat(1,1))
8241         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8242         vv(1)=pizda(1,1)+pizda(2,2)
8243         vv(2)=pizda(2,1)-pizda(1,2)
8244         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8245      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8246         if (calc_grad) then
8247 C Explicit gradient in virtual-dihedral angles.
8248         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8249      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8250         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8251         vv(1)=pizda(1,1)+pizda(2,2)
8252         vv(2)=pizda(2,1)-pizda(1,2)
8253         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8254      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8255      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8256 C Cartesian gradient
8257         do iii=1,2
8258           do kkk=1,5
8259             do lll=1,3
8260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8261      &          pizda(1,1))
8262               vv(1)=pizda(1,1)+pizda(2,2)
8263               vv(2)=pizda(2,1)-pizda(1,2)
8264               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8265      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8266      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8267             enddo
8268           enddo
8269         enddo
8270         endif ! calc_grad
8271       endif
8272 1112  continue
8273       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8274 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8275 cd        write (2,*) 'ijkl',i,j,k,l
8276 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8277 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8278 cd      endif
8279 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8280 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8281 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8282 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8283       if (calc_grad) then
8284       if (j.lt.nres-1) then
8285         j1=j+1
8286         j2=j-1
8287       else
8288         j1=j-1
8289         j2=j-2
8290       endif
8291       if (l.lt.nres-1) then
8292         l1=l+1
8293         l2=l-1
8294       else
8295         l1=l-1
8296         l2=l-2
8297       endif
8298 cd      eij=1.0d0
8299 cd      ekl=1.0d0
8300 cd      ekont=1.0d0
8301 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8302 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8303 C        summed up outside the subrouine as for the other subroutines
8304 C        handling long-range interactions. The old code is commented out
8305 C        with "cgrad" to keep track of changes.
8306       do ll=1,3
8307 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8308 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8309         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8310         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8311 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8312 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8313 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8314 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8315 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8316 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8317 c     &   gradcorr5ij,
8318 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8319 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8320 cgrad        ghalf=0.5d0*ggg1(ll)
8321 cd        ghalf=0.0d0
8322         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8323         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8324         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8325         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8326         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8327         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8328 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8329 cgrad        ghalf=0.5d0*ggg2(ll)
8330 cd        ghalf=0.0d0
8331         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8332         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8333         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8334         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8335         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8336         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8337       enddo
8338       endif ! calc_grad
8339 cd      goto 1112
8340 cgrad      do m=i+1,j-1
8341 cgrad        do ll=1,3
8342 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8343 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8344 cgrad        enddo
8345 cgrad      enddo
8346 cgrad      do m=k+1,l-1
8347 cgrad        do ll=1,3
8348 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8349 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8350 cgrad        enddo
8351 cgrad      enddo
8352 c1112  continue
8353 cgrad      do m=i+2,j2
8354 cgrad        do ll=1,3
8355 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8356 cgrad        enddo
8357 cgrad      enddo
8358 cgrad      do m=k+2,l2
8359 cgrad        do ll=1,3
8360 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8361 cgrad        enddo
8362 cgrad      enddo
8363 cd      do iii=1,nres-3
8364 cd        write (2,*) iii,g_corr5_loc(iii)
8365 cd      enddo
8366       eello5=ekont*eel5
8367 cd      write (2,*) 'ekont',ekont
8368 cd      write (iout,*) 'eello5',ekont*eel5
8369       return
8370       end
8371 c--------------------------------------------------------------------------
8372       double precision function eello6(i,j,k,l,jj,kk)
8373       implicit real*8 (a-h,o-z)
8374       include 'DIMENSIONS'
8375       include 'DIMENSIONS.ZSCOPT'
8376       include 'COMMON.IOUNITS'
8377       include 'COMMON.CHAIN'
8378       include 'COMMON.DERIV'
8379       include 'COMMON.INTERACT'
8380       include 'COMMON.CONTACTS'
8381       include 'COMMON.CONTMAT'
8382       include 'COMMON.CORRMAT'
8383       include 'COMMON.TORSION'
8384       include 'COMMON.VAR'
8385       include 'COMMON.GEO'
8386       include 'COMMON.FFIELD'
8387       double precision ggg1(3),ggg2(3)
8388 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8389 cd        eello6=0.0d0
8390 cd        return
8391 cd      endif
8392 cd      write (iout,*)
8393 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8394 cd     &   ' and',k,l
8395       eello6_1=0.0d0
8396       eello6_2=0.0d0
8397       eello6_3=0.0d0
8398       eello6_4=0.0d0
8399       eello6_5=0.0d0
8400       eello6_6=0.0d0
8401 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8402 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8403       do iii=1,2
8404         do kkk=1,5
8405           do lll=1,3
8406             derx(lll,kkk,iii)=0.0d0
8407           enddo
8408         enddo
8409       enddo
8410 cd      eij=facont_hb(jj,i)
8411 cd      ekl=facont_hb(kk,k)
8412 cd      ekont=eij*ekl
8413 cd      eij=1.0d0
8414 cd      ekl=1.0d0
8415 cd      ekont=1.0d0
8416       if (l.eq.j+1) then
8417         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8418         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8419         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8420         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8421         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8422         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8423       else
8424         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8425         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8426         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8427         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8428         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8429           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8430         else
8431           eello6_5=0.0d0
8432         endif
8433         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8434       endif
8435 C If turn contributions are considered, they will be handled separately.
8436       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8437 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8438 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8439 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8440 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8441 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8442 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8443 cd      goto 1112
8444       if (calc_grad) then
8445       if (j.lt.nres-1) then
8446         j1=j+1
8447         j2=j-1
8448       else
8449         j1=j-1
8450         j2=j-2
8451       endif
8452       if (l.lt.nres-1) then
8453         l1=l+1
8454         l2=l-1
8455       else
8456         l1=l-1
8457         l2=l-2
8458       endif
8459       do ll=1,3
8460 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8461 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8462 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8463 cgrad        ghalf=0.5d0*ggg1(ll)
8464 cd        ghalf=0.0d0
8465         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8466         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8467         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8468         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8469         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8470         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8471         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8472         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8473 cgrad        ghalf=0.5d0*ggg2(ll)
8474 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8475 cd        ghalf=0.0d0
8476         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8477         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8478         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8479         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8480         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8481         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8482       enddo
8483       endif ! calc_grad
8484 cd      goto 1112
8485 cgrad      do m=i+1,j-1
8486 cgrad        do ll=1,3
8487 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8488 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8489 cgrad        enddo
8490 cgrad      enddo
8491 cgrad      do m=k+1,l-1
8492 cgrad        do ll=1,3
8493 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8494 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8495 cgrad        enddo
8496 cgrad      enddo
8497 cgrad1112  continue
8498 cgrad      do m=i+2,j2
8499 cgrad        do ll=1,3
8500 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8501 cgrad        enddo
8502 cgrad      enddo
8503 cgrad      do m=k+2,l2
8504 cgrad        do ll=1,3
8505 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8506 cgrad        enddo
8507 cgrad      enddo
8508 cd      do iii=1,nres-3
8509 cd        write (2,*) iii,g_corr6_loc(iii)
8510 cd      enddo
8511       eello6=ekont*eel6
8512 cd      write (2,*) 'ekont',ekont
8513 cd      write (iout,*) 'eello6',ekont*eel6
8514       return
8515       end
8516 c--------------------------------------------------------------------------
8517       double precision function eello6_graph1(i,j,k,l,imat,swap)
8518       implicit real*8 (a-h,o-z)
8519       include 'DIMENSIONS'
8520       include 'DIMENSIONS.ZSCOPT'
8521       include 'COMMON.IOUNITS'
8522       include 'COMMON.CHAIN'
8523       include 'COMMON.DERIV'
8524       include 'COMMON.INTERACT'
8525       include 'COMMON.CONTACTS'
8526       include 'COMMON.CONTMAT'
8527       include 'COMMON.CORRMAT'
8528       include 'COMMON.TORSION'
8529       include 'COMMON.VAR'
8530       include 'COMMON.GEO'
8531       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8532       logical swap
8533       logical lprn
8534       common /kutas/ lprn
8535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8536 C                                                                              C
8537 C      Parallel       Antiparallel                                             C
8538 C                                                                              C
8539 C          o             o                                                     C
8540 C         /l\           /j\                                                    C
8541 C        /   \         /   \                                                   C
8542 C       /| o |         | o |\                                                  C
8543 C     \ j|/k\|  /   \  |/k\|l /                                                C
8544 C      \ /   \ /     \ /   \ /                                                 C
8545 C       o     o       o     o                                                  C
8546 C       i             i                                                        C
8547 C                                                                              C
8548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8549       itk=itype2loc(itype(k))
8550       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8551       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8552       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8553       call transpose2(EUgC(1,1,k),auxmat(1,1))
8554       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8555       vv1(1)=pizda1(1,1)-pizda1(2,2)
8556       vv1(2)=pizda1(1,2)+pizda1(2,1)
8557       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8558       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8559       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8560       s5=scalar2(vv(1),Dtobr2(1,i))
8561 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8562       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8563       if (calc_grad) then
8564       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8565      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8566      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8567      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8568      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8569      & +scalar2(vv(1),Dtobr2der(1,i)))
8570       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8571       vv1(1)=pizda1(1,1)-pizda1(2,2)
8572       vv1(2)=pizda1(1,2)+pizda1(2,1)
8573       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8574       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8575       if (l.eq.j+1) then
8576         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8577      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8578      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8579      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8580      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8581       else
8582         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8583      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8584      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8585      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8586      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8587       endif
8588       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8589       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8590       vv1(1)=pizda1(1,1)-pizda1(2,2)
8591       vv1(2)=pizda1(1,2)+pizda1(2,1)
8592       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8593      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8594      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8595      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8596       do iii=1,2
8597         if (swap) then
8598           ind=3-iii
8599         else
8600           ind=iii
8601         endif
8602         do kkk=1,5
8603           do lll=1,3
8604             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8605             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8606             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8607             call transpose2(EUgC(1,1,k),auxmat(1,1))
8608             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8609      &        pizda1(1,1))
8610             vv1(1)=pizda1(1,1)-pizda1(2,2)
8611             vv1(2)=pizda1(1,2)+pizda1(2,1)
8612             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8613             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8614      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8615             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8616      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8617             s5=scalar2(vv(1),Dtobr2(1,i))
8618             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8619           enddo
8620         enddo
8621       enddo
8622       endif ! calc_grad
8623       return
8624       end
8625 c----------------------------------------------------------------------------
8626       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8627       implicit real*8 (a-h,o-z)
8628       include 'DIMENSIONS'
8629       include 'DIMENSIONS.ZSCOPT'
8630       include 'COMMON.IOUNITS'
8631       include 'COMMON.CHAIN'
8632       include 'COMMON.DERIV'
8633       include 'COMMON.INTERACT'
8634       include 'COMMON.CONTACTS'
8635       include 'COMMON.CONTMAT'
8636       include 'COMMON.CORRMAT'
8637       include 'COMMON.TORSION'
8638       include 'COMMON.VAR'
8639       include 'COMMON.GEO'
8640       logical swap
8641       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8642      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8643       logical lprn
8644       common /kutas/ lprn
8645 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8646 C                                                                              C
8647 C      Parallel       Antiparallel                                             C
8648 C                                                                              C
8649 C          o             o                                                     C
8650 C     \   /l\           /j\   /                                                C
8651 C      \ /   \         /   \ /                                                 C
8652 C       o| o |         | o |o                                                  C
8653 C     \ j|/k\|      \  |/k\|l                                                  C
8654 C      \ /   \       \ /   \                                                   C
8655 C       o             o                                                        C
8656 C       i             i                                                        C
8657 C                                                                              C
8658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8659 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8660 C AL 7/4/01 s1 would occur in the sixth-order moment,
8661 C           but not in a cluster cumulant
8662 #ifdef MOMENT
8663       s1=dip(1,jj,i)*dip(1,kk,k)
8664 #endif
8665       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8666       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8667       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8668       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8669       call transpose2(EUg(1,1,k),auxmat(1,1))
8670       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8671       vv(1)=pizda(1,1)-pizda(2,2)
8672       vv(2)=pizda(1,2)+pizda(2,1)
8673       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8674 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8675 #ifdef MOMENT
8676       eello6_graph2=-(s1+s2+s3+s4)
8677 #else
8678       eello6_graph2=-(s2+s3+s4)
8679 #endif
8680 c      eello6_graph2=-s3
8681 C Derivatives in gamma(i-1)
8682       if (calc_grad) then
8683       if (i.gt.1) then
8684 #ifdef MOMENT
8685         s1=dipderg(1,jj,i)*dip(1,kk,k)
8686 #endif
8687         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8688         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8689         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8690         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8691 #ifdef MOMENT
8692         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8693 #else
8694         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8695 #endif
8696 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8697       endif
8698 C Derivatives in gamma(k-1)
8699 #ifdef MOMENT
8700       s1=dip(1,jj,i)*dipderg(1,kk,k)
8701 #endif
8702       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8703       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8704       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8705       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8706       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8707       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8708       vv(1)=pizda(1,1)-pizda(2,2)
8709       vv(2)=pizda(1,2)+pizda(2,1)
8710       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8711 #ifdef MOMENT
8712       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8713 #else
8714       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8715 #endif
8716 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8717 C Derivatives in gamma(j-1) or gamma(l-1)
8718       if (j.gt.1) then
8719 #ifdef MOMENT
8720         s1=dipderg(3,jj,i)*dip(1,kk,k)
8721 #endif
8722         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8723         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8724         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8725         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8726         vv(1)=pizda(1,1)-pizda(2,2)
8727         vv(2)=pizda(1,2)+pizda(2,1)
8728         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8729 #ifdef MOMENT
8730         if (swap) then
8731           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8732         else
8733           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8734         endif
8735 #endif
8736         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8737 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8738       endif
8739 C Derivatives in gamma(l-1) or gamma(j-1)
8740       if (l.gt.1) then
8741 #ifdef MOMENT
8742         s1=dip(1,jj,i)*dipderg(3,kk,k)
8743 #endif
8744         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8745         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8746         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8747         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8748         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8749         vv(1)=pizda(1,1)-pizda(2,2)
8750         vv(2)=pizda(1,2)+pizda(2,1)
8751         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8752 #ifdef MOMENT
8753         if (swap) then
8754           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8755         else
8756           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8757         endif
8758 #endif
8759         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8760 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8761       endif
8762 C Cartesian derivatives.
8763       if (lprn) then
8764         write (2,*) 'In eello6_graph2'
8765         do iii=1,2
8766           write (2,*) 'iii=',iii
8767           do kkk=1,5
8768             write (2,*) 'kkk=',kkk
8769             do jjj=1,2
8770               write (2,'(3(2f10.5),5x)')
8771      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8772             enddo
8773           enddo
8774         enddo
8775       endif
8776       do iii=1,2
8777         do kkk=1,5
8778           do lll=1,3
8779 #ifdef MOMENT
8780             if (iii.eq.1) then
8781               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8782             else
8783               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8784             endif
8785 #endif
8786             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8787      &        auxvec(1))
8788             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8789             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8790      &        auxvec(1))
8791             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8792             call transpose2(EUg(1,1,k),auxmat(1,1))
8793             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8794      &        pizda(1,1))
8795             vv(1)=pizda(1,1)-pizda(2,2)
8796             vv(2)=pizda(1,2)+pizda(2,1)
8797             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8798 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8799 #ifdef MOMENT
8800             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8801 #else
8802             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8803 #endif
8804             if (swap) then
8805               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8806             else
8807               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8808             endif
8809           enddo
8810         enddo
8811       enddo
8812       endif ! calc_grad
8813       return
8814       end
8815 c----------------------------------------------------------------------------
8816       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8817       implicit real*8 (a-h,o-z)
8818       include 'DIMENSIONS'
8819       include 'DIMENSIONS.ZSCOPT'
8820       include 'COMMON.IOUNITS'
8821       include 'COMMON.CHAIN'
8822       include 'COMMON.DERIV'
8823       include 'COMMON.INTERACT'
8824       include 'COMMON.CONTACTS'
8825       include 'COMMON.CONTMAT'
8826       include 'COMMON.CORRMAT'
8827       include 'COMMON.TORSION'
8828       include 'COMMON.VAR'
8829       include 'COMMON.GEO'
8830       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8831       logical swap
8832 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8833 C                                                                              C
8834 C      Parallel       Antiparallel                                             C
8835 C                                                                              C
8836 C          o             o                                                     C
8837 C         /l\   /   \   /j\                                                    C
8838 C        /   \ /     \ /   \                                                   C
8839 C       /| o |o       o| o |\                                                  C
8840 C       j|/k\|  /      |/k\|l /                                                C
8841 C        /   \ /       /   \ /                                                 C
8842 C       /     o       /     o                                                  C
8843 C       i             i                                                        C
8844 C                                                                              C
8845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8846 C
8847 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8848 C           energy moment and not to the cluster cumulant.
8849       iti=itortyp(itype(i))
8850       if (j.lt.nres-1) then
8851         itj1=itype2loc(itype(j+1))
8852       else
8853         itj1=nloctyp
8854       endif
8855       itk=itype2loc(itype(k))
8856       itk1=itype2loc(itype(k+1))
8857       if (l.lt.nres-1) then
8858         itl1=itype2loc(itype(l+1))
8859       else
8860         itl1=nloctyp
8861       endif
8862 #ifdef MOMENT
8863       s1=dip(4,jj,i)*dip(4,kk,k)
8864 #endif
8865       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8866       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8867       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8868       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8869       call transpose2(EE(1,1,k),auxmat(1,1))
8870       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8871       vv(1)=pizda(1,1)+pizda(2,2)
8872       vv(2)=pizda(2,1)-pizda(1,2)
8873       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8874 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8875 cd     & "sum",-(s2+s3+s4)
8876 #ifdef MOMENT
8877       eello6_graph3=-(s1+s2+s3+s4)
8878 #else
8879       eello6_graph3=-(s2+s3+s4)
8880 #endif
8881 c      eello6_graph3=-s4
8882 C Derivatives in gamma(k-1)
8883       if (calc_grad) then
8884       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8885       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8886       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8887       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8888 C Derivatives in gamma(l-1)
8889       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8890       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8891       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8892       vv(1)=pizda(1,1)+pizda(2,2)
8893       vv(2)=pizda(2,1)-pizda(1,2)
8894       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8895       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8896 C Cartesian derivatives.
8897       do iii=1,2
8898         do kkk=1,5
8899           do lll=1,3
8900 #ifdef MOMENT
8901             if (iii.eq.1) then
8902               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8903             else
8904               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8905             endif
8906 #endif
8907             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8908      &        auxvec(1))
8909             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8910             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8911      &        auxvec(1))
8912             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8913             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8914      &        pizda(1,1))
8915             vv(1)=pizda(1,1)+pizda(2,2)
8916             vv(2)=pizda(2,1)-pizda(1,2)
8917             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8918 #ifdef MOMENT
8919             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8920 #else
8921             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8922 #endif
8923             if (swap) then
8924               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8925             else
8926               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8927             endif
8928 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8929           enddo
8930         enddo
8931       enddo
8932       endif ! calc_grad
8933       return
8934       end
8935 c----------------------------------------------------------------------------
8936       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8937       implicit real*8 (a-h,o-z)
8938       include 'DIMENSIONS'
8939       include 'DIMENSIONS.ZSCOPT'
8940       include 'COMMON.IOUNITS'
8941       include 'COMMON.CHAIN'
8942       include 'COMMON.DERIV'
8943       include 'COMMON.INTERACT'
8944       include 'COMMON.CONTACTS'
8945       include 'COMMON.CONTMAT'
8946       include 'COMMON.CORRMAT'
8947       include 'COMMON.TORSION'
8948       include 'COMMON.VAR'
8949       include 'COMMON.GEO'
8950       include 'COMMON.FFIELD'
8951       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8952      & auxvec1(2),auxmat1(2,2)
8953       logical swap
8954 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8955 C                                                                              C
8956 C      Parallel       Antiparallel                                             C
8957 C                                                                              C
8958 C          o             o                                                     C
8959 C         /l\   /   \   /j\                                                    C
8960 C        /   \ /     \ /   \                                                   C
8961 C       /| o |o       o| o |\                                                  C
8962 C     \ j|/k\|      \  |/k\|l                                                  C
8963 C      \ /   \       \ /   \                                                   C
8964 C       o     \       o     \                                                  C
8965 C       i             i                                                        C
8966 C                                                                              C
8967 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8968 C
8969 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8970 C           energy moment and not to the cluster cumulant.
8971 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8972       iti=itype2loc(itype(i))
8973       itj=itype2loc(itype(j))
8974       if (j.lt.nres-1) then
8975         itj1=itype2loc(itype(j+1))
8976       else
8977         itj1=nloctyp
8978       endif
8979       itk=itype2loc(itype(k))
8980       if (k.lt.nres-1) then
8981         itk1=itype2loc(itype(k+1))
8982       else
8983         itk1=nloctyp
8984       endif
8985       itl=itype2loc(itype(l))
8986       if (l.lt.nres-1) then
8987         itl1=itype2loc(itype(l+1))
8988       else
8989         itl1=nloctyp
8990       endif
8991 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8992 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8993 cd     & ' itl',itl,' itl1',itl1
8994 #ifdef MOMENT
8995       if (imat.eq.1) then
8996         s1=dip(3,jj,i)*dip(3,kk,k)
8997       else
8998         s1=dip(2,jj,j)*dip(2,kk,l)
8999       endif
9000 #endif
9001       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9002       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9003       if (j.eq.l+1) then
9004         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9005         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9006       else
9007         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9008         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9009       endif
9010       call transpose2(EUg(1,1,k),auxmat(1,1))
9011       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9012       vv(1)=pizda(1,1)-pizda(2,2)
9013       vv(2)=pizda(2,1)+pizda(1,2)
9014       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9015 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9016 #ifdef MOMENT
9017       eello6_graph4=-(s1+s2+s3+s4)
9018 #else
9019       eello6_graph4=-(s2+s3+s4)
9020 #endif
9021 C Derivatives in gamma(i-1)
9022       if (calc_grad) then
9023       if (i.gt.1) then
9024 #ifdef MOMENT
9025         if (imat.eq.1) then
9026           s1=dipderg(2,jj,i)*dip(3,kk,k)
9027         else
9028           s1=dipderg(4,jj,j)*dip(2,kk,l)
9029         endif
9030 #endif
9031         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9032         if (j.eq.l+1) then
9033           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9034           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9035         else
9036           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9037           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9038         endif
9039         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9040         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9041 cd          write (2,*) 'turn6 derivatives'
9042 #ifdef MOMENT
9043           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9044 #else
9045           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9046 #endif
9047         else
9048 #ifdef MOMENT
9049           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9050 #else
9051           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9052 #endif
9053         endif
9054       endif
9055 C Derivatives in gamma(k-1)
9056 #ifdef MOMENT
9057       if (imat.eq.1) then
9058         s1=dip(3,jj,i)*dipderg(2,kk,k)
9059       else
9060         s1=dip(2,jj,j)*dipderg(4,kk,l)
9061       endif
9062 #endif
9063       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9064       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9065       if (j.eq.l+1) then
9066         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9067         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9068       else
9069         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9070         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9071       endif
9072       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9073       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9074       vv(1)=pizda(1,1)-pizda(2,2)
9075       vv(2)=pizda(2,1)+pizda(1,2)
9076       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9077       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9078 #ifdef MOMENT
9079         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9080 #else
9081         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9082 #endif
9083       else
9084 #ifdef MOMENT
9085         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9086 #else
9087         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9088 #endif
9089       endif
9090 C Derivatives in gamma(j-1) or gamma(l-1)
9091       if (l.eq.j+1 .and. l.gt.1) then
9092         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9093         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9094         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9095         vv(1)=pizda(1,1)-pizda(2,2)
9096         vv(2)=pizda(2,1)+pizda(1,2)
9097         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9098         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9099       else if (j.gt.1) then
9100         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9101         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9102         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9103         vv(1)=pizda(1,1)-pizda(2,2)
9104         vv(2)=pizda(2,1)+pizda(1,2)
9105         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9106         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9107           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9108         else
9109           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9110         endif
9111       endif
9112 C Cartesian derivatives.
9113       do iii=1,2
9114         do kkk=1,5
9115           do lll=1,3
9116 #ifdef MOMENT
9117             if (iii.eq.1) then
9118               if (imat.eq.1) then
9119                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9120               else
9121                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9122               endif
9123             else
9124               if (imat.eq.1) then
9125                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9126               else
9127                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9128               endif
9129             endif
9130 #endif
9131             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9132      &        auxvec(1))
9133             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9134             if (j.eq.l+1) then
9135               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9136      &          b1(1,j+1),auxvec(1))
9137               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9138             else
9139               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9140      &          b1(1,l+1),auxvec(1))
9141               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9142             endif
9143             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9144      &        pizda(1,1))
9145             vv(1)=pizda(1,1)-pizda(2,2)
9146             vv(2)=pizda(2,1)+pizda(1,2)
9147             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9148             if (swap) then
9149               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9150 #ifdef MOMENT
9151                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9152      &             -(s1+s2+s4)
9153 #else
9154                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9155      &             -(s2+s4)
9156 #endif
9157                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9158               else
9159 #ifdef MOMENT
9160                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9161 #else
9162                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9163 #endif
9164                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9165               endif
9166             else
9167 #ifdef MOMENT
9168               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9169 #else
9170               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9171 #endif
9172               if (l.eq.j+1) then
9173                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9174               else
9175                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9176               endif
9177             endif
9178           enddo
9179         enddo
9180       enddo
9181       endif ! calc_grad
9182       return
9183       end
9184 c----------------------------------------------------------------------------
9185       double precision function eello_turn6(i,jj,kk)
9186       implicit real*8 (a-h,o-z)
9187       include 'DIMENSIONS'
9188       include 'DIMENSIONS.ZSCOPT'
9189       include 'COMMON.IOUNITS'
9190       include 'COMMON.CHAIN'
9191       include 'COMMON.DERIV'
9192       include 'COMMON.INTERACT'
9193       include 'COMMON.CONTACTS'
9194       include 'COMMON.CONTMAT'
9195       include 'COMMON.CORRMAT'
9196       include 'COMMON.TORSION'
9197       include 'COMMON.VAR'
9198       include 'COMMON.GEO'
9199       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9200      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9201      &  ggg1(3),ggg2(3)
9202       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9203      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9204 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9205 C           the respective energy moment and not to the cluster cumulant.
9206       s1=0.0d0
9207       s8=0.0d0
9208       s13=0.0d0
9209 c
9210       eello_turn6=0.0d0
9211       j=i+4
9212       k=i+1
9213       l=i+3
9214       iti=itype2loc(itype(i))
9215       itk=itype2loc(itype(k))
9216       itk1=itype2loc(itype(k+1))
9217       itl=itype2loc(itype(l))
9218       itj=itype2loc(itype(j))
9219 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9220 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9221 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9222 cd        eello6=0.0d0
9223 cd        return
9224 cd      endif
9225 cd      write (iout,*)
9226 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9227 cd     &   ' and',k,l
9228 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9229       do iii=1,2
9230         do kkk=1,5
9231           do lll=1,3
9232             derx_turn(lll,kkk,iii)=0.0d0
9233           enddo
9234         enddo
9235       enddo
9236 cd      eij=1.0d0
9237 cd      ekl=1.0d0
9238 cd      ekont=1.0d0
9239       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9240 cd      eello6_5=0.0d0
9241 cd      write (2,*) 'eello6_5',eello6_5
9242 #ifdef MOMENT
9243       call transpose2(AEA(1,1,1),auxmat(1,1))
9244       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9245       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9246       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9247 #endif
9248       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9249       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9250       s2 = scalar2(b1(1,k),vtemp1(1))
9251 #ifdef MOMENT
9252       call transpose2(AEA(1,1,2),atemp(1,1))
9253       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9254       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9255       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9256 #endif
9257       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9258       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9259       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9260 #ifdef MOMENT
9261       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9262       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9263       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9264       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9265       ss13 = scalar2(b1(1,k),vtemp4(1))
9266       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9267 #endif
9268 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9269 c      s1=0.0d0
9270 c      s2=0.0d0
9271 c      s8=0.0d0
9272 c      s12=0.0d0
9273 c      s13=0.0d0
9274       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9275 C Derivatives in gamma(i+2)
9276       if (calc_grad) then
9277       s1d =0.0d0
9278       s8d =0.0d0
9279 #ifdef MOMENT
9280       call transpose2(AEA(1,1,1),auxmatd(1,1))
9281       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9282       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9283       call transpose2(AEAderg(1,1,2),atempd(1,1))
9284       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9285       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9286 #endif
9287       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9288       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9289       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9290 c      s1d=0.0d0
9291 c      s2d=0.0d0
9292 c      s8d=0.0d0
9293 c      s12d=0.0d0
9294 c      s13d=0.0d0
9295       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9296 C Derivatives in gamma(i+3)
9297 #ifdef MOMENT
9298       call transpose2(AEA(1,1,1),auxmatd(1,1))
9299       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9300       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9301       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9302 #endif
9303       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9304       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9305       s2d = scalar2(b1(1,k),vtemp1d(1))
9306 #ifdef MOMENT
9307       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9308       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9309 #endif
9310       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9311 #ifdef MOMENT
9312       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9313       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9314       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9315 #endif
9316 c      s1d=0.0d0
9317 c      s2d=0.0d0
9318 c      s8d=0.0d0
9319 c      s12d=0.0d0
9320 c      s13d=0.0d0
9321 #ifdef MOMENT
9322       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9323      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9324 #else
9325       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9326      &               -0.5d0*ekont*(s2d+s12d)
9327 #endif
9328 C Derivatives in gamma(i+4)
9329       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9330       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9331       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9332 #ifdef MOMENT
9333       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9334       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9335       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9336 #endif
9337 c      s1d=0.0d0
9338 c      s2d=0.0d0
9339 c      s8d=0.0d0
9340 C      s12d=0.0d0
9341 c      s13d=0.0d0
9342 #ifdef MOMENT
9343       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9344 #else
9345       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9346 #endif
9347 C Derivatives in gamma(i+5)
9348 #ifdef MOMENT
9349       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9350       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9351       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9352 #endif
9353       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9354       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9355       s2d = scalar2(b1(1,k),vtemp1d(1))
9356 #ifdef MOMENT
9357       call transpose2(AEA(1,1,2),atempd(1,1))
9358       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9359       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9360 #endif
9361       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9362       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9363 #ifdef MOMENT
9364       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9365       ss13d = scalar2(b1(1,k),vtemp4d(1))
9366       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9367 #endif
9368 c      s1d=0.0d0
9369 c      s2d=0.0d0
9370 c      s8d=0.0d0
9371 c      s12d=0.0d0
9372 c      s13d=0.0d0
9373 #ifdef MOMENT
9374       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9375      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9376 #else
9377       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9378      &               -0.5d0*ekont*(s2d+s12d)
9379 #endif
9380 C Cartesian derivatives
9381       do iii=1,2
9382         do kkk=1,5
9383           do lll=1,3
9384 #ifdef MOMENT
9385             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9386             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9387             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9388 #endif
9389             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9390             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9391      &          vtemp1d(1))
9392             s2d = scalar2(b1(1,k),vtemp1d(1))
9393 #ifdef MOMENT
9394             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9395             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9396             s8d = -(atempd(1,1)+atempd(2,2))*
9397      &           scalar2(cc(1,1,l),vtemp2(1))
9398 #endif
9399             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9400      &           auxmatd(1,1))
9401             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9402             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9403 c      s1d=0.0d0
9404 c      s2d=0.0d0
9405 c      s8d=0.0d0
9406 c      s12d=0.0d0
9407 c      s13d=0.0d0
9408 #ifdef MOMENT
9409             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9410      &        - 0.5d0*(s1d+s2d)
9411 #else
9412             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9413      &        - 0.5d0*s2d
9414 #endif
9415 #ifdef MOMENT
9416             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9417      &        - 0.5d0*(s8d+s12d)
9418 #else
9419             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9420      &        - 0.5d0*s12d
9421 #endif
9422           enddo
9423         enddo
9424       enddo
9425 #ifdef MOMENT
9426       do kkk=1,5
9427         do lll=1,3
9428           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9429      &      achuj_tempd(1,1))
9430           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9431           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9432           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9433           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9434           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9435      &      vtemp4d(1))
9436           ss13d = scalar2(b1(1,k),vtemp4d(1))
9437           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9438           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9439         enddo
9440       enddo
9441 #endif
9442 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9443 cd     &  16*eel_turn6_num
9444 cd      goto 1112
9445       if (j.lt.nres-1) then
9446         j1=j+1
9447         j2=j-1
9448       else
9449         j1=j-1
9450         j2=j-2
9451       endif
9452       if (l.lt.nres-1) then
9453         l1=l+1
9454         l2=l-1
9455       else
9456         l1=l-1
9457         l2=l-2
9458       endif
9459       do ll=1,3
9460 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9461 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9462 cgrad        ghalf=0.5d0*ggg1(ll)
9463 cd        ghalf=0.0d0
9464         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9465         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9466         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9467      &    +ekont*derx_turn(ll,2,1)
9468         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9469         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9470      &    +ekont*derx_turn(ll,4,1)
9471         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9472         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9473         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9474 cgrad        ghalf=0.5d0*ggg2(ll)
9475 cd        ghalf=0.0d0
9476         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9477      &    +ekont*derx_turn(ll,2,2)
9478         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9479         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9480      &    +ekont*derx_turn(ll,4,2)
9481         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9482         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9483         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9484       enddo
9485 cd      goto 1112
9486 cgrad      do m=i+1,j-1
9487 cgrad        do ll=1,3
9488 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9489 cgrad        enddo
9490 cgrad      enddo
9491 cgrad      do m=k+1,l-1
9492 cgrad        do ll=1,3
9493 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9494 cgrad        enddo
9495 cgrad      enddo
9496 cgrad1112  continue
9497 cgrad      do m=i+2,j2
9498 cgrad        do ll=1,3
9499 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9500 cgrad        enddo
9501 cgrad      enddo
9502 cgrad      do m=k+2,l2
9503 cgrad        do ll=1,3
9504 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9505 cgrad        enddo
9506 cgrad      enddo
9507 cd      do iii=1,nres-3
9508 cd        write (2,*) iii,g_corr6_loc(iii)
9509 cd      enddo
9510       endif ! calc_grad
9511       eello_turn6=ekont*eel_turn6
9512 cd      write (2,*) 'ekont',ekont
9513 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9514       return
9515       end
9516 #endif
9517 crc-------------------------------------------------
9518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9519       subroutine Eliptransfer(eliptran)
9520       implicit real*8 (a-h,o-z)
9521       include 'DIMENSIONS'
9522       include 'DIMENSIONS.ZSCOPT'
9523       include 'COMMON.GEO'
9524       include 'COMMON.VAR'
9525       include 'COMMON.LOCAL'
9526       include 'COMMON.CHAIN'
9527       include 'COMMON.DERIV'
9528       include 'COMMON.INTERACT'
9529       include 'COMMON.IOUNITS'
9530       include 'COMMON.CALC'
9531       include 'COMMON.CONTROL'
9532       include 'COMMON.SPLITELE'
9533       include 'COMMON.SBRIDGE'
9534 C this is done by Adasko
9535 C      print *,"wchodze"
9536 C structure of box:
9537 C      water
9538 C--bordliptop-- buffore starts
9539 C--bufliptop--- here true lipid starts
9540 C      lipid
9541 C--buflipbot--- lipid ends buffore starts
9542 C--bordlipbot--buffore ends
9543 c      call cartprint
9544 c      write (iout,*) "Eliptransfer peplipran",pepliptran
9545       eliptran=0.0
9546       do i=1,nres
9547 C       do i=1,1
9548         if (itype(i).eq.ntyp1) cycle
9549
9550         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9551         if (positi.le.0) positi=positi+boxzsize
9552 C        print *,i
9553 C first for peptide groups
9554 c for each residue check if it is in lipid or lipid water border area
9555        if ((positi.gt.bordlipbot)
9556      &.and.(positi.lt.bordliptop)) then
9557 C the energy transfer exist
9558         if (positi.lt.buflipbot) then
9559 C what fraction I am in
9560          fracinbuf=1.0d0-
9561      &        ((positi-bordlipbot)/lipbufthick)
9562 C lipbufthick is thickenes of lipid buffore
9563          sslip=sscalelip(fracinbuf)
9564          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9565          eliptran=eliptran+sslip*pepliptran
9566          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9567          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9568 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9569         elseif (positi.gt.bufliptop) then
9570          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9571          sslip=sscalelip(fracinbuf)
9572          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9573          eliptran=eliptran+sslip*pepliptran
9574          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9575          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9576 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9577 C          print *, "doing sscalefor top part"
9578 C         print *,i,sslip,fracinbuf,ssgradlip
9579         else
9580          eliptran=eliptran+pepliptran
9581 C         print *,"I am in true lipid"
9582         endif
9583 C       else
9584 C       eliptran=elpitran+0.0 ! I am in water
9585        endif
9586        enddo
9587 C       print *, "nic nie bylo w lipidzie?"
9588 C now multiply all by the peptide group transfer factor
9589 C       eliptran=eliptran*pepliptran
9590 C now the same for side chains
9591 CV       do i=1,1
9592        do i=1,nres
9593         if (itype(i).eq.ntyp1) cycle
9594         positi=(mod(c(3,i+nres),boxzsize))
9595         if (positi.le.0) positi=positi+boxzsize
9596 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
9597 c     &   bordliptop
9598 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9599 c for each residue check if it is in lipid or lipid water border area
9600 C       respos=mod(c(3,i+nres),boxzsize)
9601 C       print *,positi,bordlipbot,buflipbot
9602        if ((positi.gt.bordlipbot)
9603      & .and.(positi.lt.bordliptop)) then
9604 C the energy transfer exist
9605         if (positi.lt.buflipbot) then
9606          fracinbuf=1.0d0-
9607      &     ((positi-bordlipbot)/lipbufthick)
9608 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
9609 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
9610 C lipbufthick is thickenes of lipid buffore
9611          sslip=sscalelip(fracinbuf)
9612 c         write (iout,*) "sslip",sslip
9613          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9614          eliptran=eliptran+sslip*liptranene(itype(i))
9615          gliptranx(3,i)=gliptranx(3,i)
9616      &+ssgradlip*liptranene(itype(i))
9617          gliptranc(3,i-1)= gliptranc(3,i-1)
9618      &+ssgradlip*liptranene(itype(i))
9619 C         print *,"doing sccale for lower part"
9620         elseif (positi.gt.bufliptop) then
9621          fracinbuf=1.0d0-
9622      &((bordliptop-positi)/lipbufthick)
9623          sslip=sscalelip(fracinbuf)
9624          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9625          eliptran=eliptran+sslip*liptranene(itype(i))
9626          gliptranx(3,i)=gliptranx(3,i)
9627      &+ssgradlip*liptranene(itype(i))
9628          gliptranc(3,i-1)= gliptranc(3,i-1)
9629      &+ssgradlip*liptranene(itype(i))
9630 C          print *, "doing sscalefor top part",sslip,fracinbuf
9631         else
9632          eliptran=eliptran+liptranene(itype(i))
9633 C         print *,"I am in true lipid"
9634         endif
9635         endif ! if in lipid or buffor
9636 C       else
9637 C       eliptran=elpitran+0.0 ! I am in water
9638 c        write (iout,*) "eliptran",eliptran
9639        enddo
9640        return
9641        end
9642
9643
9644 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9645
9646       SUBROUTINE MATVEC2(A1,V1,V2)
9647       implicit real*8 (a-h,o-z)
9648       include 'DIMENSIONS'
9649       DIMENSION A1(2,2),V1(2),V2(2)
9650 c      DO 1 I=1,2
9651 c        VI=0.0
9652 c        DO 3 K=1,2
9653 c    3     VI=VI+A1(I,K)*V1(K)
9654 c        Vaux(I)=VI
9655 c    1 CONTINUE
9656
9657       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9658       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9659
9660       v2(1)=vaux1
9661       v2(2)=vaux2
9662       END
9663 C---------------------------------------
9664       SUBROUTINE MATMAT2(A1,A2,A3)
9665       implicit real*8 (a-h,o-z)
9666       include 'DIMENSIONS'
9667       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9668 c      DIMENSION AI3(2,2)
9669 c        DO  J=1,2
9670 c          A3IJ=0.0
9671 c          DO K=1,2
9672 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9673 c          enddo
9674 c          A3(I,J)=A3IJ
9675 c       enddo
9676 c      enddo
9677
9678       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9679       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9680       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9681       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9682
9683       A3(1,1)=AI3_11
9684       A3(2,1)=AI3_21
9685       A3(1,2)=AI3_12
9686       A3(2,2)=AI3_22
9687       END
9688
9689 c-------------------------------------------------------------------------
9690       double precision function scalar2(u,v)
9691       implicit none
9692       double precision u(2),v(2)
9693       double precision sc
9694       integer i
9695       scalar2=u(1)*v(1)+u(2)*v(2)
9696       return
9697       end
9698
9699 C-----------------------------------------------------------------------------
9700
9701       subroutine transpose2(a,at)
9702       implicit none
9703       double precision a(2,2),at(2,2)
9704       at(1,1)=a(1,1)
9705       at(1,2)=a(2,1)
9706       at(2,1)=a(1,2)
9707       at(2,2)=a(2,2)
9708       return
9709       end
9710 c--------------------------------------------------------------------------
9711       subroutine transpose(n,a,at)
9712       implicit none
9713       integer n,i,j
9714       double precision a(n,n),at(n,n)
9715       do i=1,n
9716         do j=1,n
9717           at(j,i)=a(i,j)
9718         enddo
9719       enddo
9720       return
9721       end
9722 C---------------------------------------------------------------------------
9723       subroutine prodmat3(a1,a2,kk,transp,prod)
9724       implicit none
9725       integer i,j
9726       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9727       logical transp
9728 crc      double precision auxmat(2,2),prod_(2,2)
9729
9730       if (transp) then
9731 crc        call transpose2(kk(1,1),auxmat(1,1))
9732 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9733 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9734
9735            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9736      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9737            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9738      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9739            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9740      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9741            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9742      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9743
9744       else
9745 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9746 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9747
9748            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9749      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9750            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9751      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9752            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9753      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9754            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9755      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9756
9757       endif
9758 c      call transpose2(a2(1,1),a2t(1,1))
9759
9760 crc      print *,transp
9761 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9762 crc      print *,((prod(i,j),i=1,2),j=1,2)
9763
9764       return
9765       end
9766 C-----------------------------------------------------------------------------
9767       double precision function scalar(u,v)
9768       implicit none
9769       double precision u(3),v(3)
9770       double precision sc
9771       integer i
9772       sc=0.0d0
9773       do i=1,3
9774         sc=sc+u(i)*v(i)
9775       enddo
9776       scalar=sc
9777       return
9778       end
9779 C-----------------------------------------------------------------------
9780       double precision function sscale(r)
9781       double precision r,gamm
9782       include "COMMON.SPLITELE"
9783       if(r.lt.r_cut-rlamb) then
9784         sscale=1.0d0
9785       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9786         gamm=(r-(r_cut-rlamb))/rlamb
9787         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9788       else
9789         sscale=0d0
9790       endif
9791       return
9792       end
9793 C-----------------------------------------------------------------------
9794 C-----------------------------------------------------------------------
9795       double precision function sscagrad(r)
9796       double precision r,gamm
9797       include "COMMON.SPLITELE"
9798       if(r.lt.r_cut-rlamb) then
9799         sscagrad=0.0d0
9800       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9801         gamm=(r-(r_cut-rlamb))/rlamb
9802         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9803       else
9804         sscagrad=0.0d0
9805       endif
9806       return
9807       end
9808 C-----------------------------------------------------------------------
9809 C-----------------------------------------------------------------------
9810       double precision function sscalelip(r)
9811       double precision r,gamm
9812       include "COMMON.SPLITELE"
9813 C      if(r.lt.r_cut-rlamb) then
9814 C        sscale=1.0d0
9815 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9816 C        gamm=(r-(r_cut-rlamb))/rlamb
9817         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9818 C      else
9819 C        sscale=0d0
9820 C      endif
9821       return
9822       end
9823 C-----------------------------------------------------------------------
9824       double precision function sscagradlip(r)
9825       double precision r,gamm
9826       include "COMMON.SPLITELE"
9827 C     if(r.lt.r_cut-rlamb) then
9828 C        sscagrad=0.0d0
9829 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9830 C        gamm=(r-(r_cut-rlamb))/rlamb
9831         sscagradlip=r*(6*r-6.0d0)
9832 C      else
9833 C        sscagrad=0.0d0
9834 C      endif
9835       return
9836       end
9837
9838 C-----------------------------------------------------------------------
9839        subroutine set_shield_fac
9840       implicit real*8 (a-h,o-z)
9841       include 'DIMENSIONS'
9842       include 'DIMENSIONS.ZSCOPT'
9843       include 'COMMON.CHAIN'
9844       include 'COMMON.DERIV'
9845       include 'COMMON.IOUNITS'
9846       include 'COMMON.SHIELD'
9847       include 'COMMON.INTERACT'
9848 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9849       double precision div77_81/0.974996043d0/,
9850      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9851
9852 C the vector between center of side_chain and peptide group
9853        double precision pep_side(3),long,side_calf(3),
9854      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9855      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9856 C the line belowe needs to be changed for FGPROC>1
9857       do i=1,nres-1
9858       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9859       ishield_list(i)=0
9860 Cif there two consequtive dummy atoms there is no peptide group between them
9861 C the line below has to be changed for FGPROC>1
9862       VolumeTotal=0.0
9863       do k=1,nres
9864        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9865        dist_pep_side=0.0
9866        dist_side_calf=0.0
9867        do j=1,3
9868 C first lets set vector conecting the ithe side-chain with kth side-chain
9869       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9870 C      pep_side(j)=2.0d0
9871 C and vector conecting the side-chain with its proper calfa
9872       side_calf(j)=c(j,k+nres)-c(j,k)
9873 C      side_calf(j)=2.0d0
9874       pept_group(j)=c(j,i)-c(j,i+1)
9875 C lets have their lenght
9876       dist_pep_side=pep_side(j)**2+dist_pep_side
9877       dist_side_calf=dist_side_calf+side_calf(j)**2
9878       dist_pept_group=dist_pept_group+pept_group(j)**2
9879       enddo
9880        dist_pep_side=dsqrt(dist_pep_side)
9881        dist_pept_group=dsqrt(dist_pept_group)
9882        dist_side_calf=dsqrt(dist_side_calf)
9883       do j=1,3
9884         pep_side_norm(j)=pep_side(j)/dist_pep_side
9885         side_calf_norm(j)=dist_side_calf
9886       enddo
9887 C now sscale fraction
9888        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9889 C       print *,buff_shield,"buff"
9890 C now sscale
9891         if (sh_frac_dist.le.0.0) cycle
9892 C If we reach here it means that this side chain reaches the shielding sphere
9893 C Lets add him to the list for gradient
9894         ishield_list(i)=ishield_list(i)+1
9895 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9896 C this list is essential otherwise problem would be O3
9897         shield_list(ishield_list(i),i)=k
9898 C Lets have the sscale value
9899         if (sh_frac_dist.gt.1.0) then
9900          scale_fac_dist=1.0d0
9901          do j=1,3
9902          sh_frac_dist_grad(j)=0.0d0
9903          enddo
9904         else
9905          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9906      &                   *(2.0*sh_frac_dist-3.0d0)
9907          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9908      &                  /dist_pep_side/buff_shield*0.5
9909 C remember for the final gradient multiply sh_frac_dist_grad(j)
9910 C for side_chain by factor -2 !
9911          do j=1,3
9912          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9913 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9914 C     &                    sh_frac_dist_grad(j)
9915          enddo
9916         endif
9917 C        if ((i.eq.3).and.(k.eq.2)) then
9918 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9919 C     & ,"TU"
9920 C        endif
9921
9922 C this is what is now we have the distance scaling now volume...
9923       short=short_r_sidechain(itype(k))
9924       long=long_r_sidechain(itype(k))
9925       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9926 C now costhet_grad
9927 C       costhet=0.0d0
9928        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9929 C       costhet_fac=0.0d0
9930        do j=1,3
9931          costhet_grad(j)=costhet_fac*pep_side(j)
9932        enddo
9933 C remember for the final gradient multiply costhet_grad(j)
9934 C for side_chain by factor -2 !
9935 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9936 C pep_side0pept_group is vector multiplication
9937       pep_side0pept_group=0.0
9938       do j=1,3
9939       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9940       enddo
9941       cosalfa=(pep_side0pept_group/
9942      & (dist_pep_side*dist_side_calf))
9943       fac_alfa_sin=1.0-cosalfa**2
9944       fac_alfa_sin=dsqrt(fac_alfa_sin)
9945       rkprim=fac_alfa_sin*(long-short)+short
9946 C now costhet_grad
9947        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9948        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9949
9950        do j=1,3
9951          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9952      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9953      &*(long-short)/fac_alfa_sin*cosalfa/
9954      &((dist_pep_side*dist_side_calf))*
9955      &((side_calf(j))-cosalfa*
9956      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9957
9958         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9959      &*(long-short)/fac_alfa_sin*cosalfa
9960      &/((dist_pep_side*dist_side_calf))*
9961      &(pep_side(j)-
9962      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9963        enddo
9964
9965       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9966      &                    /VSolvSphere_div
9967      &                    *wshield
9968 C now the gradient...
9969 C grad_shield is gradient of Calfa for peptide groups
9970 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9971 C     &               costhet,cosphi
9972 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9973 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9974       do j=1,3
9975       grad_shield(j,i)=grad_shield(j,i)
9976 C gradient po skalowaniu
9977      &                +(sh_frac_dist_grad(j)
9978 C  gradient po costhet
9979      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9980      &-scale_fac_dist*(cosphi_grad_long(j))
9981      &/(1.0-cosphi) )*div77_81
9982      &*VofOverlap
9983 C grad_shield_side is Cbeta sidechain gradient
9984       grad_shield_side(j,ishield_list(i),i)=
9985      &        (sh_frac_dist_grad(j)*(-2.0d0)
9986      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9987      &       +scale_fac_dist*(cosphi_grad_long(j))
9988      &        *2.0d0/(1.0-cosphi))
9989      &        *div77_81*VofOverlap
9990
9991        grad_shield_loc(j,ishield_list(i),i)=
9992      &   scale_fac_dist*cosphi_grad_loc(j)
9993      &        *2.0d0/(1.0-cosphi)
9994      &        *div77_81*VofOverlap
9995       enddo
9996       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9997       enddo
9998       fac_shield(i)=VolumeTotal*div77_81+div4_81
9999 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10000       enddo
10001       return
10002       end
10003 C--------------------------------------------------------------------------
10004 C first for shielding is setting of function of side-chains
10005        subroutine set_shield_fac2
10006       implicit real*8 (a-h,o-z)
10007       include 'DIMENSIONS'
10008       include 'DIMENSIONS.ZSCOPT'
10009       include 'COMMON.CHAIN'
10010       include 'COMMON.DERIV'
10011       include 'COMMON.IOUNITS'
10012       include 'COMMON.SHIELD'
10013       include 'COMMON.INTERACT'
10014 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10015       double precision div77_81/0.974996043d0/,
10016      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10017
10018 C the vector between center of side_chain and peptide group
10019        double precision pep_side(3),long,side_calf(3),
10020      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10021      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10022 C the line belowe needs to be changed for FGPROC>1
10023       do i=1,nres-1
10024       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10025       ishield_list(i)=0
10026 Cif there two consequtive dummy atoms there is no peptide group between them
10027 C the line below has to be changed for FGPROC>1
10028       VolumeTotal=0.0
10029       do k=1,nres
10030        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10031        dist_pep_side=0.0
10032        dist_side_calf=0.0
10033        do j=1,3
10034 C first lets set vector conecting the ithe side-chain with kth side-chain
10035       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10036 C      pep_side(j)=2.0d0
10037 C and vector conecting the side-chain with its proper calfa
10038       side_calf(j)=c(j,k+nres)-c(j,k)
10039 C      side_calf(j)=2.0d0
10040       pept_group(j)=c(j,i)-c(j,i+1)
10041 C lets have their lenght
10042       dist_pep_side=pep_side(j)**2+dist_pep_side
10043       dist_side_calf=dist_side_calf+side_calf(j)**2
10044       dist_pept_group=dist_pept_group+pept_group(j)**2
10045       enddo
10046        dist_pep_side=dsqrt(dist_pep_side)
10047        dist_pept_group=dsqrt(dist_pept_group)
10048        dist_side_calf=dsqrt(dist_side_calf)
10049       do j=1,3
10050         pep_side_norm(j)=pep_side(j)/dist_pep_side
10051         side_calf_norm(j)=dist_side_calf
10052       enddo
10053 C now sscale fraction
10054        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10055 C       print *,buff_shield,"buff"
10056 C now sscale
10057         if (sh_frac_dist.le.0.0) cycle
10058 C If we reach here it means that this side chain reaches the shielding sphere
10059 C Lets add him to the list for gradient
10060         ishield_list(i)=ishield_list(i)+1
10061 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10062 C this list is essential otherwise problem would be O3
10063         shield_list(ishield_list(i),i)=k
10064 C Lets have the sscale value
10065         if (sh_frac_dist.gt.1.0) then
10066          scale_fac_dist=1.0d0
10067          do j=1,3
10068          sh_frac_dist_grad(j)=0.0d0
10069          enddo
10070         else
10071          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10072      &                   *(2.0d0*sh_frac_dist-3.0d0)
10073          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10074      &                  /dist_pep_side/buff_shield*0.5d0
10075 C remember for the final gradient multiply sh_frac_dist_grad(j)
10076 C for side_chain by factor -2 !
10077          do j=1,3
10078          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10079 C         sh_frac_dist_grad(j)=0.0d0
10080 C         scale_fac_dist=1.0d0
10081 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10082 C     &                    sh_frac_dist_grad(j)
10083          enddo
10084         endif
10085 C this is what is now we have the distance scaling now volume...
10086       short=short_r_sidechain(itype(k))
10087       long=long_r_sidechain(itype(k))
10088       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10089       sinthet=short/dist_pep_side*costhet
10090 C now costhet_grad
10091 C       costhet=0.6d0
10092 C       sinthet=0.8
10093        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10094 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10095 C     &             -short/dist_pep_side**2/costhet)
10096 C       costhet_fac=0.0d0
10097        do j=1,3
10098          costhet_grad(j)=costhet_fac*pep_side(j)
10099        enddo
10100 C remember for the final gradient multiply costhet_grad(j)
10101 C for side_chain by factor -2 !
10102 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10103 C pep_side0pept_group is vector multiplication
10104       pep_side0pept_group=0.0d0
10105       do j=1,3
10106       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10107       enddo
10108       cosalfa=(pep_side0pept_group/
10109      & (dist_pep_side*dist_side_calf))
10110       fac_alfa_sin=1.0d0-cosalfa**2
10111       fac_alfa_sin=dsqrt(fac_alfa_sin)
10112       rkprim=fac_alfa_sin*(long-short)+short
10113 C      rkprim=short
10114
10115 C now costhet_grad
10116        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10117 C       cosphi=0.6
10118        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10119        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10120      &      dist_pep_side**2)
10121 C       sinphi=0.8
10122        do j=1,3
10123          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10124      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10125      &*(long-short)/fac_alfa_sin*cosalfa/
10126      &((dist_pep_side*dist_side_calf))*
10127      &((side_calf(j))-cosalfa*
10128      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10129 C       cosphi_grad_long(j)=0.0d0
10130         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10131      &*(long-short)/fac_alfa_sin*cosalfa
10132      &/((dist_pep_side*dist_side_calf))*
10133      &(pep_side(j)-
10134      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10135 C       cosphi_grad_loc(j)=0.0d0
10136        enddo
10137 C      print *,sinphi,sinthet
10138       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10139      &                    /VSolvSphere_div
10140 C     &                    *wshield
10141 C now the gradient...
10142       do j=1,3
10143       grad_shield(j,i)=grad_shield(j,i)
10144 C gradient po skalowaniu
10145      &                +(sh_frac_dist_grad(j)*VofOverlap
10146 C  gradient po costhet
10147      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10148      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10149      &       sinphi/sinthet*costhet*costhet_grad(j)
10150      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10151      & )*wshield
10152 C grad_shield_side is Cbeta sidechain gradient
10153       grad_shield_side(j,ishield_list(i),i)=
10154      &        (sh_frac_dist_grad(j)*(-2.0d0)
10155      &        *VofOverlap
10156      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10157      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10158      &       sinphi/sinthet*costhet*costhet_grad(j)
10159      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10160      &       )*wshield
10161
10162        grad_shield_loc(j,ishield_list(i),i)=
10163      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10164      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10165      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10166      &        ))
10167      &        *wshield
10168       enddo
10169       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10170       enddo
10171       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10172 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10173 c     &  " wshield",wshield
10174 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10175       enddo
10176       return
10177       end
10178 C--------------------------------------------------------------------------
10179       double precision function tschebyshev(m,n,x,y)
10180       implicit none
10181       include "DIMENSIONS"
10182       integer i,m,n
10183       double precision x(n),y,yy(0:maxvar),aux
10184 c Tschebyshev polynomial. Note that the first term is omitted
10185 c m=0: the constant term is included
10186 c m=1: the constant term is not included
10187       yy(0)=1.0d0
10188       yy(1)=y
10189       do i=2,n
10190         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10191       enddo
10192       aux=0.0d0
10193       do i=m,n
10194         aux=aux+x(i)*yy(i)
10195       enddo
10196       tschebyshev=aux
10197       return
10198       end
10199 C--------------------------------------------------------------------------
10200       double precision function gradtschebyshev(m,n,x,y)
10201       implicit none
10202       include "DIMENSIONS"
10203       integer i,m,n
10204       double precision x(n+1),y,yy(0:maxvar),aux
10205 c Tschebyshev polynomial. Note that the first term is omitted
10206 c m=0: the constant term is included
10207 c m=1: the constant term is not included
10208       yy(0)=1.0d0
10209       yy(1)=2.0d0*y
10210       do i=2,n
10211         yy(i)=2*y*yy(i-1)-yy(i-2)
10212       enddo
10213       aux=0.0d0
10214       do i=m,n
10215         aux=aux+x(i+1)*yy(i)*(i+1)
10216 C        print *, x(i+1),yy(i),i
10217       enddo
10218       gradtschebyshev=aux
10219       return
10220       end
10221 c----------------------------------------------------------------------------
10222       double precision function sscale2(r,r_cut,r0,rlamb)
10223       implicit none
10224       double precision r,gamm,r_cut,r0,rlamb,rr
10225       rr = dabs(r-r0)
10226 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10227 c      write (2,*) "rr",rr
10228       if(rr.lt.r_cut-rlamb) then
10229         sscale2=1.0d0
10230       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10231         gamm=(rr-(r_cut-rlamb))/rlamb
10232         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10233       else
10234         sscale2=0d0
10235       endif
10236       return
10237       end
10238 C-----------------------------------------------------------------------
10239       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10240       implicit none
10241       double precision r,gamm,r_cut,r0,rlamb,rr
10242       rr = dabs(r-r0)
10243       if(rr.lt.r_cut-rlamb) then
10244         sscalgrad2=0.0d0
10245       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10246         gamm=(rr-(r_cut-rlamb))/rlamb
10247         if (r.ge.r0) then
10248           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10249         else
10250           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10251         endif
10252       else
10253         sscalgrad2=0.0d0
10254       endif
10255       return
10256       end
10257 c----------------------------------------------------------------------------
10258       subroutine e_saxs(Esaxs_constr)
10259       implicit none
10260       include 'DIMENSIONS'
10261       include 'DIMENSIONS.ZSCOPT'
10262       include 'DIMENSIONS.FREE'
10263 #ifdef MPI
10264       include "mpif.h"
10265       include "COMMON.SETUP"
10266       integer IERR
10267 #endif
10268       include 'COMMON.SBRIDGE'
10269       include 'COMMON.CHAIN'
10270       include 'COMMON.GEO'
10271       include 'COMMON.LOCAL'
10272       include 'COMMON.INTERACT'
10273       include 'COMMON.VAR'
10274       include 'COMMON.IOUNITS'
10275       include 'COMMON.DERIV'
10276       include 'COMMON.CONTROL'
10277       include 'COMMON.NAMES'
10278       include 'COMMON.FFIELD'
10279       include 'COMMON.LANGEVIN'
10280       include 'COMMON.SAXS'
10281 c
10282       double precision Esaxs_constr
10283       integer i,iint,j,k,l
10284       double precision PgradC(maxSAXS,3,maxres),
10285      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10286 #ifdef MPI
10287       double precision PgradC_(maxSAXS,3,maxres),
10288      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10289 #endif
10290       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10291      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10292      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10293      & auxX,auxX1,CACAgrad,Cnorm
10294       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10295       double precision dist
10296       external dist
10297 c  SAXS restraint penalty function
10298 #ifdef DEBUG
10299       write(iout,*) "------- SAXS penalty function start -------"
10300       write (iout,*) "nsaxs",nsaxs
10301       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10302       write (iout,*) "Psaxs"
10303       do i=1,nsaxs
10304         write (iout,'(i5,e15.5)') i, Psaxs(i)
10305       enddo
10306 #endif
10307       Esaxs_constr = 0.0d0
10308       do k=1,nsaxs
10309         Pcalc(k)=0.0d0
10310         do j=1,nres
10311           do l=1,3
10312             PgradC(k,l,j)=0.0d0
10313             PgradX(k,l,j)=0.0d0
10314           enddo
10315         enddo
10316       enddo
10317       do i=iatsc_s,iatsc_e
10318        if (itype(i).eq.ntyp1) cycle
10319        do iint=1,nint_gr(i)
10320          do j=istart(i,iint),iend(i,iint)
10321            if (itype(j).eq.ntyp1) cycle
10322 #ifdef ALLSAXS
10323            dijCACA=dist(i,j)
10324            dijCASC=dist(i,j+nres)
10325            dijSCCA=dist(i+nres,j)
10326            dijSCSC=dist(i+nres,j+nres)
10327            sigma2CACA=2.0d0/(pstok**2)
10328            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10329            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10330            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10331            do k=1,nsaxs
10332              dk = distsaxs(k)
10333              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10334              if (itype(j).ne.10) then
10335              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10336              else
10337              endif
10338              expCASC = 0.0d0
10339              if (itype(i).ne.10) then
10340              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10341              else
10342              expSCCA = 0.0d0
10343              endif
10344              if (itype(i).ne.10 .and. itype(j).ne.10) then
10345              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10346              else
10347              expSCSC = 0.0d0
10348              endif
10349              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10350 #ifdef DEBUG
10351              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10352 #endif
10353              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10354              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10355              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10356              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10357              do l=1,3
10358 c CA CA
10359                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10360                PgradC(k,l,i) = PgradC(k,l,i)-aux
10361                PgradC(k,l,j) = PgradC(k,l,j)+aux
10362 c CA SC
10363                if (itype(j).ne.10) then
10364                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10365                PgradC(k,l,i) = PgradC(k,l,i)-aux
10366                PgradC(k,l,j) = PgradC(k,l,j)+aux
10367                PgradX(k,l,j) = PgradX(k,l,j)+aux
10368                endif
10369 c SC CA
10370                if (itype(i).ne.10) then
10371                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10372                PgradX(k,l,i) = PgradX(k,l,i)-aux
10373                PgradC(k,l,i) = PgradC(k,l,i)-aux
10374                PgradC(k,l,j) = PgradC(k,l,j)+aux
10375                endif
10376 c SC SC
10377                if (itype(i).ne.10 .and. itype(j).ne.10) then
10378                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10379                PgradC(k,l,i) = PgradC(k,l,i)-aux
10380                PgradC(k,l,j) = PgradC(k,l,j)+aux
10381                PgradX(k,l,i) = PgradX(k,l,i)-aux
10382                PgradX(k,l,j) = PgradX(k,l,j)+aux
10383                endif
10384              enddo ! l
10385            enddo ! k
10386 #else
10387            dijCACA=dist(i,j)
10388            sigma2CACA=scal_rad**2*0.25d0/
10389      &        (restok(itype(j))**2+restok(itype(i))**2)
10390
10391            IF (saxs_cutoff.eq.0) THEN
10392            do k=1,nsaxs
10393              dk = distsaxs(k)
10394              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10395              Pcalc(k) = Pcalc(k)+expCACA
10396              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10397              do l=1,3
10398                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10399                PgradC(k,l,i) = PgradC(k,l,i)-aux
10400                PgradC(k,l,j) = PgradC(k,l,j)+aux
10401              enddo ! l
10402            enddo ! k
10403            ELSE
10404            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10405            do k=1,nsaxs
10406              dk = distsaxs(k)
10407 c             write (2,*) "ijk",i,j,k
10408              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10409              if (sss2.eq.0.0d0) cycle
10410              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10411              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10412              Pcalc(k) = Pcalc(k)+expCACA
10413 #ifdef DEBUG
10414              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10415 #endif
10416              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10417      &             ssgrad2*expCACA/sss2
10418              do l=1,3
10419 c CA CA
10420                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10421                PgradC(k,l,i) = PgradC(k,l,i)+aux
10422                PgradC(k,l,j) = PgradC(k,l,j)-aux
10423              enddo ! l
10424            enddo ! k
10425            ENDIF
10426 #endif
10427          enddo ! j
10428        enddo ! iint
10429       enddo ! i
10430 #ifdef MPI
10431       if (nfgtasks.gt.1) then
10432         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10433      &    MPI_SUM,king,FG_COMM,IERR)
10434         if (fg_rank.eq.king) then
10435           do k=1,nsaxs
10436             Pcalc(k) = Pcalc_(k)
10437           enddo
10438         endif
10439         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10440      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10441         if (fg_rank.eq.king) then
10442           do i=1,nres
10443             do l=1,3
10444               do k=1,nsaxs
10445                 PgradC(k,l,i) = PgradC_(k,l,i)
10446               enddo
10447             enddo
10448           enddo
10449         endif
10450 #ifdef ALLSAXS
10451         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10452      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10453         if (fg_rank.eq.king) then
10454           do i=1,nres
10455             do l=1,3
10456               do k=1,nsaxs
10457                 PgradX(k,l,i) = PgradX_(k,l,i)
10458               enddo
10459             enddo
10460           enddo
10461         endif
10462 #endif
10463       endif
10464 #endif
10465 #ifdef MPI
10466       if (fg_rank.eq.king) then
10467 #endif
10468       Cnorm = 0.0d0
10469       do k=1,nsaxs
10470         Cnorm = Cnorm + Pcalc(k)
10471       enddo
10472       Esaxs_constr = dlog(Cnorm)-wsaxs0
10473       do k=1,nsaxs
10474         if (Pcalc(k).gt.0.0d0)
10475      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10476 #ifdef DEBUG
10477         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10478 #endif
10479       enddo
10480 #ifdef DEBUG
10481       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10482 #endif
10483       do i=nnt,nct
10484         do l=1,3
10485           auxC=0.0d0
10486           auxC1=0.0d0
10487           auxX=0.0d0
10488           auxX1=0.d0
10489           do k=1,nsaxs
10490             if (Pcalc(k).gt.0)
10491      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10492             auxC1 = auxC1+PgradC(k,l,i)
10493 #ifdef ALLSAXS
10494             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10495             auxX1 = auxX1+PgradX(k,l,i)
10496 #endif
10497           enddo
10498           gsaxsC(l,i) = auxC - auxC1/Cnorm
10499 #ifdef ALLSAXS
10500           gsaxsX(l,i) = auxX - auxX1/Cnorm
10501 #endif
10502 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10503 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10504         enddo
10505       enddo
10506 #ifdef MPI
10507       endif
10508 #endif
10509       return
10510       end
10511 c----------------------------------------------------------------------------
10512       subroutine e_saxsC(Esaxs_constr)
10513       implicit none
10514       include 'DIMENSIONS'
10515       include 'DIMENSIONS.ZSCOPT'
10516       include 'DIMENSIONS.FREE'
10517 #ifdef MPI
10518       include "mpif.h"
10519       include "COMMON.SETUP"
10520       integer IERR
10521 #endif
10522       include 'COMMON.SBRIDGE'
10523       include 'COMMON.CHAIN'
10524       include 'COMMON.GEO'
10525       include 'COMMON.LOCAL'
10526       include 'COMMON.INTERACT'
10527       include 'COMMON.VAR'
10528       include 'COMMON.IOUNITS'
10529       include 'COMMON.DERIV'
10530       include 'COMMON.CONTROL'
10531       include 'COMMON.NAMES'
10532       include 'COMMON.FFIELD'
10533       include 'COMMON.LANGEVIN'
10534       include 'COMMON.SAXS'
10535 c
10536       double precision Esaxs_constr
10537       integer i,iint,j,k,l
10538       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10539 #ifdef MPI
10540       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10541 #endif
10542       double precision dk,dijCASPH,dijSCSPH,
10543      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10544      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10545      & auxX,auxX1,Cnorm
10546 c  SAXS restraint penalty function
10547 #ifdef DEBUG
10548       write(iout,*) "------- SAXS penalty function start -------"
10549       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10550      & " isaxs_end",isaxs_end
10551       write (iout,*) "nnt",nnt," ntc",nct
10552       do i=nnt,nct
10553         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10554      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10555       enddo
10556       do i=nnt,nct
10557         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10558       enddo
10559 #endif
10560       Esaxs_constr = 0.0d0
10561       logPtot=0.0d0
10562       do j=isaxs_start,isaxs_end
10563         Pcalc=0.0d0
10564         do i=1,nres
10565           do l=1,3
10566             PgradC(l,i)=0.0d0
10567             PgradX(l,i)=0.0d0
10568           enddo
10569         enddo
10570         do i=nnt,nct
10571           dijCASPH=0.0d0
10572           dijSCSPH=0.0d0
10573           do l=1,3
10574             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10575           enddo
10576           if (itype(i).ne.10) then
10577           do l=1,3
10578             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10579           enddo
10580           endif
10581           sigma2CA=2.0d0/pstok**2
10582           sigma2SC=4.0d0/restok(itype(i))**2
10583           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10584           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10585           Pcalc = Pcalc+expCASPH+expSCSPH
10586 #ifdef DEBUG
10587           write(*,*) "processor i j Pcalc",
10588      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10589 #endif
10590           CASPHgrad = sigma2CA*expCASPH
10591           SCSPHgrad = sigma2SC*expSCSPH
10592           do l=1,3
10593             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10594             PgradX(l,i) = PgradX(l,i) + aux
10595             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10596           enddo ! l
10597         enddo ! i
10598         do i=nnt,nct
10599           do l=1,3
10600             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10601             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10602           enddo
10603         enddo
10604         logPtot = logPtot - dlog(Pcalc)
10605 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10606 c     &    " logPtot",logPtot
10607       enddo ! j
10608 #ifdef MPI
10609       if (nfgtasks.gt.1) then
10610 c        write (iout,*) "logPtot before reduction",logPtot
10611         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10612      &    MPI_SUM,king,FG_COMM,IERR)
10613         logPtot = logPtot_
10614 c        write (iout,*) "logPtot after reduction",logPtot
10615         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10616      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10617         if (fg_rank.eq.king) then
10618           do i=1,nres
10619             do l=1,3
10620               gsaxsC(l,i) = gsaxsC_(l,i)
10621             enddo
10622           enddo
10623         endif
10624         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10625      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10626         if (fg_rank.eq.king) then
10627           do i=1,nres
10628             do l=1,3
10629               gsaxsX(l,i) = gsaxsX_(l,i)
10630             enddo
10631           enddo
10632         endif
10633       endif
10634 #endif
10635       Esaxs_constr = logPtot
10636       return
10637       end
10638