source/wham/src-HCD-5D/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,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 163       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 164         call e_saxs(Esaxs_constr)
 165 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 166       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 167         call e_saxsC(Esaxs_constr)
 168 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 169       else
 170         Esaxs_constr = 0.0d0
 171       endif
 172
 173 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 174       if (constr_homology.ge.1) then
 175         call e_modeller(ehomology_constr)
 176       else
 177         ehomology_constr=0.0d0
 178       endif
 179
 180 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 181 #ifdef DFA
 182 C     BARTEK for dfa test!
 183       edfadis=0.0d0
 184       if (wdfa_dist.gt.0) call edfad(edfadis)
 185 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 186       edfator=0.0d0
 187       if (wdfa_tor.gt.0) call edfat(edfator)
 188 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 189       edfanei=0.0d0
 190       if (wdfa_nei.gt.0) call edfan(edfanei)
 191 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 192       edfabet=0.0d0
 193       if (wdfa_beta.gt.0) call edfab(edfabet)
 194 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 195 #endif
 196
 197 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 198 #ifdef SPLITELE
 199       if (shield_mode.gt.0) then
 200       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 201      & +welec*fact(1)*ees
 202      & +fact(1)*wvdwpp*evdw1
 203      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 204      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 205      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 206      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 207      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 208      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 209      & +wliptran*eliptran*esaxs_constr
 210      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 211      & +wdfa_beta*edfabet
 212       else
 213       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 214      & +wvdwpp*evdw1
 215      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 216      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 217      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 218      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 219      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 220      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 221      & +wliptran*eliptran+wsaxs*esaxs_constr
 222      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 223      & +wdfa_beta*edfabet
 224       endif
 225 #else
 226       if (shield_mode.gt.0) then
 227       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 228      & +welec*fact(1)*(ees+evdw1)
 229      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 230      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 231      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 232      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 233      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 234      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 235      & +wliptran*eliptran+wsaxs*esaxs_constr
 236      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 237      & +wdfa_beta*edfabet
 238       else
 239       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 240      & +welec*fact(1)*(ees+evdw1)
 241      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 242      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 243      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 244      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 245      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 246      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 247      & +wliptran*eliptran+wsaxs*esaxs_constr
 248      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 249      & +wdfa_beta*edfabet
 250       endif
 251 #endif
 252       energia(0)=etot
 253       energia(1)=evdw
 254 #ifdef SCP14
 255       energia(2)=evdw2-evdw2_14
 256       energia(17)=evdw2_14
 257 #else
 258       energia(2)=evdw2
 259       energia(17)=0.0d0
 260 #endif
 261 #ifdef SPLITELE
 262       energia(3)=ees
 263       energia(16)=evdw1
 264 #else
 265       energia(3)=ees+evdw1
 266       energia(16)=0.0d0
 267 #endif
 268       energia(4)=ecorr
 269       energia(5)=ecorr5
 270       energia(6)=ecorr6
 271       energia(7)=eel_loc
 272       energia(8)=eello_turn3
 273       energia(9)=eello_turn4
 274       energia(10)=eturn6
 275       energia(11)=ebe
 276       energia(12)=escloc
 277       energia(13)=etors
 278       energia(14)=etors_d
 279       energia(15)=ehpb
 280       energia(18)=estr
 281       energia(19)=esccor
 282       energia(20)=edihcnstr
 283       energia(21)=evdw_t
 284       energia(22)=eliptran
 285       energia(24)=ethetacnstr
 286       energia(26)=esaxs_constr
 287       energia(27)=ehomology_constr
 288       energia(28)=edfadis
 289       energia(29)=edfator
 290       energia(30)=edfanei
 291       energia(31)=edfabet
 292 c detecting NaNQ
 293 #ifdef ISNAN
 294 #ifdef AIX
 295       if (isnan(etot).ne.0) energia(0)=1.0d+99
 296 #else
 297       if (isnan(etot)) energia(0)=1.0d+99
 298 #endif
 299 #else
 300       i=0
 301 #ifdef WINPGI
 302       idumm=proc_proc(etot,i)
 303 #else
 304       call proc_proc(etot,i)
 305 #endif
 306       if(i.eq.1)energia(0)=1.0d+99
 307 #endif
 308 #ifdef MPL
 309 c     endif
 310 #endif
 311 #ifdef DEBUG
 312       call enerprint(energia,fact)
 313 #endif
 314       if (calc_grad) then
 315 C
 316 C Sum up the components of the Cartesian gradient.
 317 C
 318 #ifdef SPLITELE
 319       do i=1,nct
 320         do j=1,3
 321       if (shield_mode.eq.0) then
 322           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 323      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 324      &                wbond*gradb(j,i)+
 325      &                wstrain*ghpbc(j,i)+
 326      &                wcorr*fact(3)*gradcorr(j,i)+
 327      &                wel_loc*fact(2)*gel_loc(j,i)+
 328      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 329      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 330      &                wcorr5*fact(4)*gradcorr5(j,i)+
 331      &                wcorr6*fact(5)*gradcorr6(j,i)+
 332      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 333      &                wsccor*fact(2)*gsccorc(j,i)+
 334      &                wliptran*gliptranc(j,i)+
 335      &                wdfa_dist*gdfad(j,i)+
 336      &                wdfa_tor*gdfat(j,i)+
 337      &                wdfa_nei*gdfan(j,i)+
 338      &                wdfa_beta*gdfab(j,i)
 339           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 340      &                  wbond*gradbx(j,i)+
 341      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 342      &                  wsccor*fact(2)*gsccorx(j,i)
 343      &                 +wliptran*gliptranx(j,i)
 344         else
 345           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 346      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 347      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 348      &                wbond*gradb(j,i)+
 349      &                wstrain*ghpbc(j,i)+
 350      &                wcorr*fact(3)*gradcorr(j,i)+
 351      &                wel_loc*fact(2)*gel_loc(j,i)+
 352      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 353      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 354      &                wcorr5*fact(4)*gradcorr5(j,i)+
 355      &                wcorr6*fact(5)*gradcorr6(j,i)+
 356      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 357      &                wsccor*fact(2)*gsccorc(j,i)
 358      &               +wliptran*gliptranc(j,i)
 359      &                 +welec*gshieldc(j,i)
 360      &                 +welec*gshieldc_loc(j,i)
 361      &                 +wcorr*gshieldc_ec(j,i)
 362      &                 +wcorr*gshieldc_loc_ec(j,i)
 363      &                 +wturn3*gshieldc_t3(j,i)
 364      &                 +wturn3*gshieldc_loc_t3(j,i)
 365      &                 +wturn4*gshieldc_t4(j,i)
 366      &                 +wturn4*gshieldc_loc_t4(j,i)
 367      &                 +wel_loc*gshieldc_ll(j,i)
 368      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 369      &                wdfa_dist*gdfad(j,i)+
 370      &                wdfa_tor*gdfat(j,i)+
 371      &                wdfa_nei*gdfan(j,i)+
 372      &                wdfa_beta*gdfab(j,i)
 373           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 374      &                 +fact(1)*wscp*gradx_scp(j,i)+
 375      &                  wbond*gradbx(j,i)+
 376      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 377      &                  wsccor*fact(2)*gsccorx(j,i)
 378      &                 +wliptran*gliptranx(j,i)
 379      &                 +welec*gshieldx(j,i)
 380      &                 +wcorr*gshieldx_ec(j,i)
 381      &                 +wturn3*gshieldx_t3(j,i)
 382      &                 +wturn4*gshieldx_t4(j,i)
 383      &                 +wel_loc*gshieldx_ll(j,i)
 384         endif
 385         enddo
 386 #else
 387       do i=1,nct
 388         do j=1,3
 389                 if (shield_mode.eq.0) then
 390           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 391      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 392      &                wbond*gradb(j,i)+
 393      &                wcorr*fact(3)*gradcorr(j,i)+
 394      &                wel_loc*fact(2)*gel_loc(j,i)+
 395      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 396      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 397      &                wcorr5*fact(4)*gradcorr5(j,i)+
 398      &                wcorr6*fact(5)*gradcorr6(j,i)+
 399      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 400      &                wsccor*fact(2)*gsccorc(j,i)
 401      &               +wliptran*gliptranc(j,i)+
 402      &                wdfa_dist*gdfad(j,i)+
 403      &                wdfa_tor*gdfat(j,i)+
 404      &                wdfa_nei*gdfan(j,i)+
 405      &                wdfa_beta*gdfab(j,i)
 406
 407           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 408      &                  wbond*gradbx(j,i)+
 409      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 410      &                  wsccor*fact(1)*gsccorx(j,i)
 411      &                 +wliptran*gliptranx(j,i)
 412               else
 413           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 414      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 415      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 416      &                wbond*gradb(j,i)+
 417      &                wcorr*fact(3)*gradcorr(j,i)+
 418      &                wel_loc*fact(2)*gel_loc(j,i)+
 419      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 420      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 421      &                wcorr5*fact(4)*gradcorr5(j,i)+
 422      &                wcorr6*fact(5)*gradcorr6(j,i)+
 423      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 424      &                wsccor*fact(2)*gsccorc(j,i)
 425      &               +wliptran*gliptranc(j,i)
 426      &                 +welec*gshieldc(j,i)
 427      &                 +welec*gshieldc_loc(j,i)
 428      &                 +wcorr*gshieldc_ec(j,i)
 429      &                 +wcorr*gshieldc_loc_ec(j,i)
 430      &                 +wturn3*gshieldc_t3(j,i)
 431      &                 +wturn3*gshieldc_loc_t3(j,i)
 432      &                 +wturn4*gshieldc_t4(j,i)
 433      &                 +wturn4*gshieldc_loc_t4(j,i)
 434      &                 +wel_loc*gshieldc_ll(j,i)
 435      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 436      &                wdfa_dist*gdfad(j,i)+
 437      &                wdfa_tor*gdfat(j,i)+
 438      &                wdfa_nei*gdfan(j,i)+
 439      &                wdfa_beta*gdfab(j,i)
 440           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 441      &                  fact(1)*wscp*gradx_scp(j,i)+
 442      &                  wbond*gradbx(j,i)+
 443      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 444      &                  wsccor*fact(1)*gsccorx(j,i)
 445      &                 +wliptran*gliptranx(j,i)
 446      &                 +welec*gshieldx(j,i)
 447      &                 +wcorr*gshieldx_ec(j,i)
 448      &                 +wturn3*gshieldx_t3(j,i)
 449      &                 +wturn4*gshieldx_t4(j,i)
 450      &                 +wel_loc*gshieldx_ll(j,i)
 451
 452          endif
 453         enddo
 454 #endif
 455       enddo
 456
 457
 458       do i=1,nres-3
 459         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 460      &   +wcorr5*fact(4)*g_corr5_loc(i)
 461      &   +wcorr6*fact(5)*g_corr6_loc(i)
 462      &   +wturn4*fact(3)*gel_loc_turn4(i)
 463      &   +wturn3*fact(2)*gel_loc_turn3(i)
 464      &   +wturn6*fact(5)*gel_loc_turn6(i)
 465      &   +wel_loc*fact(2)*gel_loc_loc(i)
 466 c     &   +wsccor*fact(1)*gsccor_loc(i)
 467 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 468       enddo
 469       endif
 470       if (dyn_ss) call dyn_set_nss
 471       return
 472       end
 473 C------------------------------------------------------------------------
 474       subroutine enerprint(energia,fact)
 475       implicit real*8 (a-h,o-z)
 476       include 'DIMENSIONS'
 477       include 'DIMENSIONS.ZSCOPT'
 478       include 'COMMON.IOUNITS'
 479       include 'COMMON.FFIELD'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CONTROL'
 482       double precision energia(0:max_ene),fact(6)
 483       etot=energia(0)
 484       evdw=energia(1)+fact(6)*energia(21)
 485 #ifdef SCP14
 486       evdw2=energia(2)+energia(17)
 487 #else
 488       evdw2=energia(2)
 489 #endif
 490       ees=energia(3)
 491 #ifdef SPLITELE
 492       evdw1=energia(16)
 493 #endif
 494       ecorr=energia(4)
 495       ecorr5=energia(5)
 496       ecorr6=energia(6)
 497       eel_loc=energia(7)
 498       eello_turn3=energia(8)
 499       eello_turn4=energia(9)
 500       eello_turn6=energia(10)
 501       ebe=energia(11)
 502       escloc=energia(12)
 503       etors=energia(13)
 504       etors_d=energia(14)
 505       ehpb=energia(15)
 506       esccor=energia(19)
 507       edihcnstr=energia(20)
 508       estr=energia(18)
 509       ethetacnstr=energia(24)
 510       eliptran=energia(22)
 511       esaxs=energia(26)
 512       ehomology_constr=energia(27)
 513 C     Bartek
 514       edfadis = energia(28)
 515       edfator = energia(29)
 516       edfanei = energia(30)
 517       edfabet = energia(31)
 518 #ifdef SPLITELE
 519       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 520      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 521      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 522 #ifdef FOURBODY
 523      &  ecorr,wcorr*fact(3),
 524      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 525 #endif
 526      &  eel_loc,
 527      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 528      &  eello_turn4,wturn4*fact(3),
 529 #ifdef FOURBODY
 530      &  eello_turn6,wturn6*fact(5),
 531 #endif
 532      &  esccor,wsccor*fact(1),edihcnstr,
 533      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 534      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 535      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 536      &  edfabet,wdfa_beta,
 537      &  etot
 538    10 format (/'Virtual-chain energies:'//
 539      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 540      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 541      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 542      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 543      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 544      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 545      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 546      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 547      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 548      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 549      & ' (SS bridges & dist. cnstr.)'/
 550 #ifdef FOURBODY
 551      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 552      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 553      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 554 #endif
 555      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 556      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 557      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 558 #ifdef FOURBODY
 559      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 560 #endif
 561      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 562      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 563      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 564      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 565      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 566      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 567      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 568      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 569      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 570      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 571      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 572      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 573      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 574      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 575      & 'ETOT=  ',1pE16.6,' (total)')
 576
 577 #else
 578       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 579      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 580      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 581 #ifdef FOURBODY
 582      &  ecorr,wcorr*fact(3),
 583      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 584 #endif
 585      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 586      &  eello_turn4,wturn4*fact(3),
 587 #ifdef FOURBODY
 588      &  eello_turn6,wturn6*fact(5),
 589 #endif
 590      &  esccor,wsccor*fact(1),edihcnstr,
 591      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 592      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 593      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 594      &  edfabet,wdfa_beta,
 595      &  etot
 596    10 format (/'Virtual-chain energies:'//
 597      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 598      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 599      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 600      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 601      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 602      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 603      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 604      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 605      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 606      & ' (SS bridges & dist. restr.)'/
 607 #ifdef FOURBODY
 608      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 609      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 610      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 611 #endif
 612      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 613      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 614      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 615 #ifdef FOURBODY
 616      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 617 #endif
 618      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 619      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 620      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 621      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 622      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 623      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 624      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 625      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 626      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 627      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 628      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 629      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 630      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 631      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 632      & 'ETOT=  ',1pE16.6,' (total)')
 633 #endif
 634       return
 635       end
 636 C-----------------------------------------------------------------------
 637       subroutine elj(evdw,evdw_t)
 638 C
 639 C This subroutine calculates the interaction energy of nonbonded side chains
 640 C assuming the LJ potential of interaction.
 641 C
 642       implicit real*8 (a-h,o-z)
 643       include 'DIMENSIONS'
 644       include 'DIMENSIONS.ZSCOPT'
 645       include "DIMENSIONS.COMPAR"
 646       parameter (accur=1.0d-10)
 647       include 'COMMON.GEO'
 648       include 'COMMON.VAR'
 649       include 'COMMON.LOCAL'
 650       include 'COMMON.CHAIN'
 651       include 'COMMON.DERIV'
 652       include 'COMMON.INTERACT'
 653       include 'COMMON.TORSION'
 654       include 'COMMON.ENEPS'
 655       include 'COMMON.SBRIDGE'
 656       include 'COMMON.NAMES'
 657       include 'COMMON.IOUNITS'
 658 #ifdef FOURBODY
 659       include 'COMMON.CONTACTS'
 660       include 'COMMON.CONTMAT'
 661 #endif
 662       dimension gg(3)
 663       integer icant
 664       external icant
 665 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 666 c ROZNICA z cluster
 667       do i=1,210
 668         do j=1,2
 669           eneps_temp(j,i)=0.0d0
 670         enddo
 671       enddo
 672 cROZNICA
 673
 674       evdw=0.0D0
 675       evdw_t=0.0d0
 676       do i=iatsc_s,iatsc_e
 677         itypi=iabs(itype(i))
 678         if (itypi.eq.ntyp1) cycle
 679         itypi1=iabs(itype(i+1))
 680         xi=c(1,nres+i)
 681         yi=c(2,nres+i)
 682         zi=c(3,nres+i)
 683 C Change 12/1/95
 684         num_conti=0
 685 C
 686 C Calculate SC interaction energy.
 687 C
 688         do iint=1,nint_gr(i)
 689 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 690 cd   &                  'iend=',iend(i,iint)
 691           do j=istart(i,iint),iend(i,iint)
 692             itypj=iabs(itype(j))
 693             if (itypj.eq.ntyp1) cycle
 694             xj=c(1,nres+j)-xi
 695             yj=c(2,nres+j)-yi
 696             zj=c(3,nres+j)-zi
 697 C Change 12/1/95 to calculate four-body interactions
 698             rij=xj*xj+yj*yj+zj*zj
 699             rrij=1.0D0/rij
 700             sqrij=dsqrt(rij)
 701             sss1=sscale(sqrij)
 702             if (sss1.eq.0.0d0) cycle
 703             sssgrad1=sscagrad(sqrij)
 704 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 705             eps0ij=eps(itypi,itypj)
 706             fac=rrij**expon2
 707             e1=fac*fac*aa
 708             e2=fac*bb
 709             evdwij=e1+e2
 710             ij=icant(itypi,itypj)
 711 c ROZNICA z cluster
 712             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 713             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 714 c
 715
 716 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 717 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 718 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 719 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 720 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 721 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 722             if (bb.gt.0.0d0) then
 723               evdw=evdw+sss1*evdwij
 724             else
 725               evdw_t=evdw_t+sss1*evdwij
 726             endif
 727             if (calc_grad) then
 728 C
 729 C Calculate the components of the gradient in DC and X
 730 C
 731             fac=-rrij*(e1+evdwij)*sss1
 732      &          +evdwij*sssgrad1/sqrij/expon
 733             gg(1)=xj*fac
 734             gg(2)=yj*fac
 735             gg(3)=zj*fac
 736             do k=1,3
 737               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 738               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 739             enddo
 740             do k=i,j-1
 741               do l=1,3
 742                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 743               enddo
 744             enddo
 745             endif
 746 #ifdef FOURBODY
 747 C
 748 C 12/1/95, revised on 5/20/97
 749 C
 750 C Calculate the contact function. The ith column of the array JCONT will
 751 C contain the numbers of atoms that make contacts with the atom I (of numbers
 752 C greater than I). The arrays FACONT and GACONT will contain the values of
 753 C the contact function and its derivative.
 754 C
 755 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 756 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 757 C Uncomment next line, if the correlation interactions are contact function only
 758             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 759               rij=dsqrt(rij)
 760               sigij=sigma(itypi,itypj)
 761               r0ij=rs0(itypi,itypj)
 762 C
 763 C Check whether the SC's are not too far to make a contact.
 764 C
 765               rcut=1.5d0*r0ij
 766               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 767 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 768 C
 769               if (fcont.gt.0.0D0) then
 770 C If the SC-SC distance if close to sigma, apply spline.
 771 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 772 cAdam &             fcont1,fprimcont1)
 773 cAdam           fcont1=1.0d0-fcont1
 774 cAdam           if (fcont1.gt.0.0d0) then
 775 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 776 cAdam             fcont=fcont*fcont1
 777 cAdam           endif
 778 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 779 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 780 cga             do k=1,3
 781 cga               gg(k)=gg(k)*eps0ij
 782 cga             enddo
 783 cga             eps0ij=-evdwij*eps0ij
 784 C Uncomment for AL's type of SC correlation interactions.
 785 cadam           eps0ij=-evdwij
 786                 num_conti=num_conti+1
 787                 jcont(num_conti,i)=j
 788                 facont(num_conti,i)=fcont*eps0ij
 789                 fprimcont=eps0ij*fprimcont/rij
 790                 fcont=expon*fcont
 791 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 792 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 793 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 794 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 795                 gacont(1,num_conti,i)=-fprimcont*xj
 796                 gacont(2,num_conti,i)=-fprimcont*yj
 797                 gacont(3,num_conti,i)=-fprimcont*zj
 798 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 799 cd              write (iout,'(2i3,3f10.5)')
 800 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 801               endif
 802             endif
 803 #endif
 804           enddo      ! j
 805         enddo        ! iint
 806 #ifdef FOURBODY
 807 C Change 12/1/95
 808         num_cont(i)=num_conti
 809 #endif
 810       enddo          ! i
 811       if (calc_grad) then
 812       do i=1,nct
 813         do j=1,3
 814           gvdwc(j,i)=expon*gvdwc(j,i)
 815           gvdwx(j,i)=expon*gvdwx(j,i)
 816         enddo
 817       enddo
 818       endif
 819 C******************************************************************************
 820 C
 821 C                              N O T E !!!
 822 C
 823 C To save time, the factor of EXPON has been extracted from ALL components
 824 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 825 C use!
 826 C
 827 C******************************************************************************
 828       return
 829       end
 830 C-----------------------------------------------------------------------------
 831       subroutine eljk(evdw,evdw_t)
 832 C
 833 C This subroutine calculates the interaction energy of nonbonded side chains
 834 C assuming the LJK potential of interaction.
 835 C
 836       implicit real*8 (a-h,o-z)
 837       include 'DIMENSIONS'
 838       include 'DIMENSIONS.ZSCOPT'
 839       include "DIMENSIONS.COMPAR"
 840       include 'COMMON.GEO'
 841       include 'COMMON.VAR'
 842       include 'COMMON.LOCAL'
 843       include 'COMMON.CHAIN'
 844       include 'COMMON.DERIV'
 845       include 'COMMON.INTERACT'
 846       include 'COMMON.ENEPS'
 847       include 'COMMON.IOUNITS'
 848       include 'COMMON.NAMES'
 849       dimension gg(3)
 850       logical scheck
 851       integer icant
 852       external icant
 853 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 854       do i=1,210
 855         do j=1,2
 856           eneps_temp(j,i)=0.0d0
 857         enddo
 858       enddo
 859       evdw=0.0D0
 860       evdw_t=0.0d0
 861       do i=iatsc_s,iatsc_e
 862         itypi=iabs(itype(i))
 863         if (itypi.eq.ntyp1) cycle
 864         itypi1=iabs(itype(i+1))
 865         xi=c(1,nres+i)
 866         yi=c(2,nres+i)
 867         zi=c(3,nres+i)
 868 C
 869 C Calculate SC interaction energy.
 870 C
 871         do iint=1,nint_gr(i)
 872           do j=istart(i,iint),iend(i,iint)
 873             itypj=iabs(itype(j))
 874             if (itypj.eq.ntyp1) cycle
 875             xj=c(1,nres+j)-xi
 876             yj=c(2,nres+j)-yi
 877             zj=c(3,nres+j)-zi
 878             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 879             fac_augm=rrij**expon
 880             e_augm=augm(itypi,itypj)*fac_augm
 881             r_inv_ij=dsqrt(rrij)
 882             rij=1.0D0/r_inv_ij
 883             sss1=sscale(rij)
 884             if (sss1.eq.0.0d0) cycle
 885             sssgrad1=sscagrad(rij)
 886             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 887             fac=r_shift_inv**expon
 888             e1=fac*fac*aa
 889             e2=fac*bb
 890             evdwij=e_augm+e1+e2
 891             ij=icant(itypi,itypj)
 892             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 893      &        /dabs(eps(itypi,itypj))
 894             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 895 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 896 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 897 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 898 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 899 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 900 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 901 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 902             if (bb.gt.0.0d0) then
 903               evdw=evdw+evdwij*sss1
 904             else
 905               evdw_t=evdw_t+evdwij*sss1
 906             endif
 907             if (calc_grad) then
 908 C
 909 C Calculate the components of the gradient in DC and X
 910 C
 911            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 912      &          +evdwij*sssgrad1*r_inv_ij/expon
 913             gg(1)=xj*fac
 914             gg(2)=yj*fac
 915             gg(3)=zj*fac
 916             do k=1,3
 917               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 918               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 919             enddo
 920             do k=i,j-1
 921               do l=1,3
 922                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 923               enddo
 924             enddo
 925             endif
 926           enddo      ! j
 927         enddo        ! iint
 928       enddo          ! i
 929       if (calc_grad) then
 930       do i=1,nct
 931         do j=1,3
 932           gvdwc(j,i)=expon*gvdwc(j,i)
 933           gvdwx(j,i)=expon*gvdwx(j,i)
 934         enddo
 935       enddo
 936       endif
 937       return
 938       end
 939 C-----------------------------------------------------------------------------
 940       subroutine ebp(evdw,evdw_t)
 941 C
 942 C This subroutine calculates the interaction energy of nonbonded side chains
 943 C assuming the Berne-Pechukas potential of interaction.
 944 C
 945       implicit real*8 (a-h,o-z)
 946       include 'DIMENSIONS'
 947       include 'DIMENSIONS.ZSCOPT'
 948       include "DIMENSIONS.COMPAR"
 949       include 'COMMON.GEO'
 950       include 'COMMON.VAR'
 951       include 'COMMON.LOCAL'
 952       include 'COMMON.CHAIN'
 953       include 'COMMON.DERIV'
 954       include 'COMMON.NAMES'
 955       include 'COMMON.INTERACT'
 956       include 'COMMON.ENEPS'
 957       include 'COMMON.IOUNITS'
 958       include 'COMMON.CALC'
 959       common /srutu/ icall
 960 c     double precision rrsave(maxdim)
 961       logical lprn
 962       integer icant
 963       external icant
 964       do i=1,210
 965         do j=1,2
 966           eneps_temp(j,i)=0.0d0
 967         enddo
 968       enddo
 969       evdw=0.0D0
 970       evdw_t=0.0d0
 971 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 972 c     if (icall.eq.0) then
 973 c       lprn=.true.
 974 c     else
 975         lprn=.false.
 976 c     endif
 977       ind=0
 978       do i=iatsc_s,iatsc_e
 979         itypi=iabs(itype(i))
 980         if (itypi.eq.ntyp1) cycle
 981         itypi1=iabs(itype(i+1))
 982         xi=c(1,nres+i)
 983         yi=c(2,nres+i)
 984         zi=c(3,nres+i)
 985         dxi=dc_norm(1,nres+i)
 986         dyi=dc_norm(2,nres+i)
 987         dzi=dc_norm(3,nres+i)
 988         dsci_inv=vbld_inv(i+nres)
 989 C
 990 C Calculate SC interaction energy.
 991 C
 992         do iint=1,nint_gr(i)
 993           do j=istart(i,iint),iend(i,iint)
 994             ind=ind+1
 995             itypj=iabs(itype(j))
 996             if (itypj.eq.ntyp1) cycle
 997             dscj_inv=vbld_inv(j+nres)
 998             chi1=chi(itypi,itypj)
 999             chi2=chi(itypj,itypi)
1000             chi12=chi1*chi2
1001             chip1=chip(itypi)
1002             chip2=chip(itypj)
1003             chip12=chip1*chip2
1004             alf1=alp(itypi)
1005             alf2=alp(itypj)
1006             alf12=0.5D0*(alf1+alf2)
1007 C For diagnostics only!!!
1008 c           chi1=0.0D0
1009 c           chi2=0.0D0
1010 c           chi12=0.0D0
1011 c           chip1=0.0D0
1012 c           chip2=0.0D0
1013 c           chip12=0.0D0
1014 c           alf1=0.0D0
1015 c           alf2=0.0D0
1016 c           alf12=0.0D0
1017             xj=c(1,nres+j)-xi
1018             yj=c(2,nres+j)-yi
1019             zj=c(3,nres+j)-zi
1020             dxj=dc_norm(1,nres+j)
1021             dyj=dc_norm(2,nres+j)
1022             dzj=dc_norm(3,nres+j)
1023             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1024 cd          if (icall.eq.0) then
1025 cd            rrsave(ind)=rrij
1026 cd          else
1027 cd            rrij=rrsave(ind)
1028 cd          endif
1029             rij=dsqrt(rrij)
1030             sss1=sscale(1.0d0/rij)
1031             if (sss1.eq.0.0d0) cycle
1032             sssgrad1=sscagrad(1.0d0/rij)
1033
1034 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1035             call sc_angular
1036 C Calculate whole angle-dependent part of epsilon and contributions
1037 C to its derivatives
1038             fac=(rrij*sigsq)**expon2
1039             e1=fac*fac*aa
1040             e2=fac*bb
1041             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1042             eps2der=evdwij*eps3rt
1043             eps3der=evdwij*eps2rt
1044             evdwij=evdwij*eps2rt*eps3rt
1045             ij=icant(itypi,itypj)
1046             aux=eps1*eps2rt**2*eps3rt**2
1047             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1048      &        /dabs(eps(itypi,itypj))
1049             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1050             if (bb.gt.0.0d0) then
1051               evdw=evdw+sss1*evdwij
1052             else
1053               evdw_t=evdw_t+sss1*evdwij
1054             endif
1055             if (calc_grad) then
1056             if (lprn) then
1057             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1058             epsi=bb**2/aa
1059             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1060      &        restyp(itypi),i,restyp(itypj),j,
1061      &        epsi,sigm,chi1,chi2,chip1,chip2,
1062      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1063      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1064      &        evdwij
1065             endif
1066 C Calculate gradient components.
1067             e1=e1*eps1*eps2rt**2*eps3rt**2
1068             fac=-expon*(e1+evdwij)
1069             sigder=fac/sigsq
1070             fac=rrij*fac
1071      &           +evdwij*sssgrad1/sss1*rij
1072 C Calculate radial part of the gradient
1073             gg(1)=xj*fac
1074             gg(2)=yj*fac
1075             gg(3)=zj*fac
1076 C Calculate the angular part of the gradient and sum add the contributions
1077 C to the appropriate components of the Cartesian gradient.
1078             call sc_grad
1079             endif
1080           enddo      ! j
1081         enddo        ! iint
1082       enddo          ! i
1083 c     stop
1084       return
1085       end
1086 C-----------------------------------------------------------------------------
1087       subroutine egb(evdw,evdw_t)
1088 C
1089 C This subroutine calculates the interaction energy of nonbonded side chains
1090 C assuming the Gay-Berne potential of interaction.
1091 C
1092       implicit real*8 (a-h,o-z)
1093       include 'DIMENSIONS'
1094       include 'DIMENSIONS.ZSCOPT'
1095       include "DIMENSIONS.COMPAR"
1096       include 'COMMON.CONTROL'
1097       include 'COMMON.GEO'
1098       include 'COMMON.VAR'
1099       include 'COMMON.LOCAL'
1100       include 'COMMON.CHAIN'
1101       include 'COMMON.DERIV'
1102       include 'COMMON.NAMES'
1103       include 'COMMON.INTERACT'
1104       include 'COMMON.ENEPS'
1105       include 'COMMON.IOUNITS'
1106       include 'COMMON.CALC'
1107       include 'COMMON.SBRIDGE'
1108       logical lprn
1109       common /srutu/icall
1110       integer icant,xshift,yshift,zshift
1111       external icant
1112       do i=1,210
1113         do j=1,2
1114           eneps_temp(j,i)=0.0d0
1115         enddo
1116       enddo
1117 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1118       evdw=0.0D0
1119       evdw_t=0.0d0
1120       lprn=.false.
1121 c      if (icall.gt.0) lprn=.true.
1122       ind=0
1123       do i=iatsc_s,iatsc_e
1124         itypi=iabs(itype(i))
1125         if (itypi.eq.ntyp1) cycle
1126         itypi1=iabs(itype(i+1))
1127         xi=c(1,nres+i)
1128         yi=c(2,nres+i)
1129         zi=c(3,nres+i)
1130 C returning the ith atom to box
1131           xi=mod(xi,boxxsize)
1132           if (xi.lt.0) xi=xi+boxxsize
1133           yi=mod(yi,boxysize)
1134           if (yi.lt.0) yi=yi+boxysize
1135           zi=mod(zi,boxzsize)
1136           if (zi.lt.0) zi=zi+boxzsize
1137        if ((zi.gt.bordlipbot)
1138      &.and.(zi.lt.bordliptop)) then
1139 C the energy transfer exist
1140         if (zi.lt.buflipbot) then
1141 C what fraction I am in
1142          fracinbuf=1.0d0-
1143      &        ((zi-bordlipbot)/lipbufthick)
1144 C lipbufthick is thickenes of lipid buffore
1145          sslipi=sscalelip(fracinbuf)
1146          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1147         elseif (zi.gt.bufliptop) then
1148          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1149          sslipi=sscalelip(fracinbuf)
1150          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1151         else
1152          sslipi=1.0d0
1153          ssgradlipi=0.0
1154         endif
1155        else
1156          sslipi=0.0d0
1157          ssgradlipi=0.0
1158        endif
1159
1160         dxi=dc_norm(1,nres+i)
1161         dyi=dc_norm(2,nres+i)
1162         dzi=dc_norm(3,nres+i)
1163         dsci_inv=vbld_inv(i+nres)
1164 C
1165 C Calculate SC interaction energy.
1166 C
1167         do iint=1,nint_gr(i)
1168           do j=istart(i,iint),iend(i,iint)
1169             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1170               call dyn_ssbond_ene(i,j,evdwij)
1171               evdw=evdw+evdwij
1172 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1173 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1174 C triple bond artifac removal
1175              do k=j+1,iend(i,iint)
1176 C search over all next residues
1177               if (dyn_ss_mask(k)) then
1178 C check if they are cysteins
1179 C              write(iout,*) 'k=',k
1180               call triple_ssbond_ene(i,j,k,evdwij)
1181 C call the energy function that removes the artifical triple disulfide
1182 C bond the soubroutine is located in ssMD.F
1183               evdw=evdw+evdwij
1184 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1185 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1186               endif!dyn_ss_mask(k)
1187              enddo! k
1188             ELSE
1189             ind=ind+1
1190             itypj=iabs(itype(j))
1191             if (itypj.eq.ntyp1) cycle
1192             dscj_inv=vbld_inv(j+nres)
1193             sig0ij=sigma(itypi,itypj)
1194             chi1=chi(itypi,itypj)
1195             chi2=chi(itypj,itypi)
1196             chi12=chi1*chi2
1197             chip1=chip(itypi)
1198             chip2=chip(itypj)
1199             chip12=chip1*chip2
1200             alf1=alp(itypi)
1201             alf2=alp(itypj)
1202             alf12=0.5D0*(alf1+alf2)
1203 C For diagnostics only!!!
1204 c           chi1=0.0D0
1205 c           chi2=0.0D0
1206 c           chi12=0.0D0
1207 c           chip1=0.0D0
1208 c           chip2=0.0D0
1209 c           chip12=0.0D0
1210 c           alf1=0.0D0
1211 c           alf2=0.0D0
1212 c           alf12=0.0D0
1213             xj=c(1,nres+j)
1214             yj=c(2,nres+j)
1215             zj=c(3,nres+j)
1216 C returning jth atom to box
1217           xj=mod(xj,boxxsize)
1218           if (xj.lt.0) xj=xj+boxxsize
1219           yj=mod(yj,boxysize)
1220           if (yj.lt.0) yj=yj+boxysize
1221           zj=mod(zj,boxzsize)
1222           if (zj.lt.0) zj=zj+boxzsize
1223        if ((zj.gt.bordlipbot)
1224      &.and.(zj.lt.bordliptop)) then
1225 C the energy transfer exist
1226         if (zj.lt.buflipbot) then
1227 C what fraction I am in
1228          fracinbuf=1.0d0-
1229      &        ((zj-bordlipbot)/lipbufthick)
1230 C lipbufthick is thickenes of lipid buffore
1231          sslipj=sscalelip(fracinbuf)
1232          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1233         elseif (zj.gt.bufliptop) then
1234          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1235          sslipj=sscalelip(fracinbuf)
1236          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1237         else
1238          sslipj=1.0d0
1239          ssgradlipj=0.0
1240         endif
1241        else
1242          sslipj=0.0d0
1243          ssgradlipj=0.0
1244        endif
1245       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1246      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1247       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1248      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1249 C       if (aa.ne.aa_aq(itypi,itypj)) then
1250
1251 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1252 C     & bb_aq(itypi,itypj)-bb,
1253 C     & sslipi,sslipj
1254 C         endif
1255
1256 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1257 C checking the distance
1258       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1259       xj_safe=xj
1260       yj_safe=yj
1261       zj_safe=zj
1262       subchap=0
1263 C finding the closest
1264       do xshift=-1,1
1265       do yshift=-1,1
1266       do zshift=-1,1
1267           xj=xj_safe+xshift*boxxsize
1268           yj=yj_safe+yshift*boxysize
1269           zj=zj_safe+zshift*boxzsize
1270           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1271           if(dist_temp.lt.dist_init) then
1272             dist_init=dist_temp
1273             xj_temp=xj
1274             yj_temp=yj
1275             zj_temp=zj
1276             subchap=1
1277           endif
1278        enddo
1279        enddo
1280        enddo
1281        if (subchap.eq.1) then
1282           xj=xj_temp-xi
1283           yj=yj_temp-yi
1284           zj=zj_temp-zi
1285        else
1286           xj=xj_safe-xi
1287           yj=yj_safe-yi
1288           zj=zj_safe-zi
1289        endif
1290
1291             dxj=dc_norm(1,nres+j)
1292             dyj=dc_norm(2,nres+j)
1293             dzj=dc_norm(3,nres+j)
1294 c            write (iout,*) i,j,xj,yj,zj
1295             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1296             rij=dsqrt(rrij)
1297             sss=sscale(1.0d0/rij)
1298             sssgrad=sscagrad(1.0d0/rij)
1299             if (sss.le.0.0) cycle
1300 C Calculate angle-dependent terms of energy and contributions to their
1301 C derivatives.
1302
1303             call sc_angular
1304             sigsq=1.0D0/sigsq
1305             sig=sig0ij*dsqrt(sigsq)
1306             rij_shift=1.0D0/rij-sig+sig0ij
1307 C I hate to put IF's in the loops, but here don't have another choice!!!!
1308             if (rij_shift.le.0.0D0) then
1309               evdw=1.0D20
1310               return
1311             endif
1312             sigder=-sig*sigsq
1313 c---------------------------------------------------------------
1314             rij_shift=1.0D0/rij_shift
1315             fac=rij_shift**expon
1316             e1=fac*fac*aa
1317             e2=fac*bb
1318             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1319             eps2der=evdwij*eps3rt
1320             eps3der=evdwij*eps2rt
1321             evdwij=evdwij*eps2rt*eps3rt
1322             if (bb.gt.0) then
1323               evdw=evdw+evdwij*sss
1324             else
1325               evdw_t=evdw_t+evdwij*sss
1326             endif
1327             ij=icant(itypi,itypj)
1328             aux=eps1*eps2rt**2*eps3rt**2
1329             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1330      &        /dabs(eps(itypi,itypj))
1331             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1332 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1333 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1334 c     &         aux*e2/eps(itypi,itypj)
1335 c            if (lprn) then
1336             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1337             epsi=bb**2/aa
1338 c#define DEBUG
1339 #ifdef DEBUG
1340             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1341      &        restyp(itypi),i,restyp(itypj),j,
1342      &        epsi,sigm,chi1,chi2,chip1,chip2,
1343      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1344      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1345      &        evdwij
1346              write (iout,*) "partial sum", evdw, evdw_t
1347 #endif
1348 c#undef DEBUG
1349 c            endif
1350             if (energy_dec) write (iout,'(a,2i5,3f10.5)')
1351      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
1352             if (calc_grad) then
1353 C Calculate gradient components.
1354             e1=e1*eps1*eps2rt**2*eps3rt**2
1355             fac=-expon*(e1+evdwij)*rij_shift
1356             sigder=fac*sigder
1357             fac=rij*fac
1358             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1359 C Calculate the radial part of the gradient
1360             gg(1)=xj*fac
1361             gg(2)=yj*fac
1362             gg(3)=zj*fac
1363 C Calculate angular part of the gradient.
1364             call sc_grad
1365             endif
1366 C            write(iout,*)  "partial sum", evdw, evdw_t
1367             ENDIF    ! dyn_ss
1368           enddo      ! j
1369         enddo        ! iint
1370       enddo          ! i
1371       return
1372       end
1373 C-----------------------------------------------------------------------------
1374       subroutine egbv(evdw,evdw_t)
1375 C
1376 C This subroutine calculates the interaction energy of nonbonded side chains
1377 C assuming the Gay-Berne-Vorobjev potential of interaction.
1378 C
1379       implicit real*8 (a-h,o-z)
1380       include 'DIMENSIONS'
1381       include 'DIMENSIONS.ZSCOPT'
1382       include "DIMENSIONS.COMPAR"
1383       include 'COMMON.GEO'
1384       include 'COMMON.VAR'
1385       include 'COMMON.LOCAL'
1386       include 'COMMON.CHAIN'
1387       include 'COMMON.DERIV'
1388       include 'COMMON.NAMES'
1389       include 'COMMON.INTERACT'
1390       include 'COMMON.ENEPS'
1391       include 'COMMON.IOUNITS'
1392       include 'COMMON.CALC'
1393       common /srutu/ icall
1394       logical lprn
1395       integer icant
1396       external icant
1397       do i=1,210
1398         do j=1,2
1399           eneps_temp(j,i)=0.0d0
1400         enddo
1401       enddo
1402       evdw=0.0D0
1403       evdw_t=0.0d0
1404 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1405       evdw=0.0D0
1406       lprn=.false.
1407 c      if (icall.gt.0) lprn=.true.
1408       ind=0
1409       do i=iatsc_s,iatsc_e
1410         itypi=iabs(itype(i))
1411         if (itypi.eq.ntyp1) cycle
1412         itypi1=iabs(itype(i+1))
1413         xi=c(1,nres+i)
1414         yi=c(2,nres+i)
1415         zi=c(3,nres+i)
1416         dxi=dc_norm(1,nres+i)
1417         dyi=dc_norm(2,nres+i)
1418         dzi=dc_norm(3,nres+i)
1419         dsci_inv=vbld_inv(i+nres)
1420 C
1421 C Calculate SC interaction energy.
1422 C
1423         do iint=1,nint_gr(i)
1424           do j=istart(i,iint),iend(i,iint)
1425             ind=ind+1
1426             itypj=iabs(itype(j))
1427             if (itypj.eq.ntyp1) cycle
1428             dscj_inv=vbld_inv(j+nres)
1429             sig0ij=sigma(itypi,itypj)
1430             r0ij=r0(itypi,itypj)
1431             chi1=chi(itypi,itypj)
1432             chi2=chi(itypj,itypi)
1433             chi12=chi1*chi2
1434             chip1=chip(itypi)
1435             chip2=chip(itypj)
1436             chip12=chip1*chip2
1437             alf1=alp(itypi)
1438             alf2=alp(itypj)
1439             alf12=0.5D0*(alf1+alf2)
1440 C For diagnostics only!!!
1441 c           chi1=0.0D0
1442 c           chi2=0.0D0
1443 c           chi12=0.0D0
1444 c           chip1=0.0D0
1445 c           chip2=0.0D0
1446 c           chip12=0.0D0
1447 c           alf1=0.0D0
1448 c           alf2=0.0D0
1449 c           alf12=0.0D0
1450             xj=c(1,nres+j)-xi
1451             yj=c(2,nres+j)-yi
1452             zj=c(3,nres+j)-zi
1453             dxj=dc_norm(1,nres+j)
1454             dyj=dc_norm(2,nres+j)
1455             dzj=dc_norm(3,nres+j)
1456             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1457             rij=dsqrt(rrij)
1458             sss=sscale(1.0d0/rij)
1459             if (sss.eq.0.0d0) cycle
1460             sssgrad=sscagrad(1.0d0/rij)
1461 C Calculate angle-dependent terms of energy and contributions to their
1462 C derivatives.
1463             call sc_angular
1464             sigsq=1.0D0/sigsq
1465             sig=sig0ij*dsqrt(sigsq)
1466             rij_shift=1.0D0/rij-sig+r0ij
1467 C I hate to put IF's in the loops, but here don't have another choice!!!!
1468             if (rij_shift.le.0.0D0) then
1469               evdw=1.0D20
1470               return
1471             endif
1472             sigder=-sig*sigsq
1473 c---------------------------------------------------------------
1474             rij_shift=1.0D0/rij_shift
1475             fac=rij_shift**expon
1476             e1=fac*fac*aa
1477             e2=fac*bb
1478             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1479             eps2der=evdwij*eps3rt
1480             eps3der=evdwij*eps2rt
1481             fac_augm=rrij**expon
1482             e_augm=augm(itypi,itypj)*fac_augm
1483             evdwij=evdwij*eps2rt*eps3rt
1484             if (bb.gt.0.0d0) then
1485               evdw=evdw+(evdwij+e_augm)*sss
1486             else
1487               evdw_t=evdw_t+(evdwij+e_augm)*sss
1488             endif
1489             ij=icant(itypi,itypj)
1490             aux=eps1*eps2rt**2*eps3rt**2
1491             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1492      &        /dabs(eps(itypi,itypj))
1493             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1494 c            eneps_temp(ij)=eneps_temp(ij)
1495 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1496 c            if (lprn) then
1497 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1498 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1499 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1500 c     &        restyp(itypi),i,restyp(itypj),j,
1501 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1502 c     &        chi1,chi2,chip1,chip2,
1503 c     &        eps1,eps2rt**2,eps3rt**2,
1504 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1505 c     &        evdwij+e_augm
1506 c            endif
1507             if (calc_grad) then
1508 C Calculate gradient components.
1509             e1=e1*eps1*eps2rt**2*eps3rt**2
1510             fac=-expon*(e1+evdwij)*rij_shift
1511             sigder=fac*sigder
1512             fac=rij*fac-2*expon*rrij*e_augm
1513             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1514 C Calculate the radial part of the gradient
1515             gg(1)=xj*fac
1516             gg(2)=yj*fac
1517             gg(3)=zj*fac
1518 C Calculate angular part of the gradient.
1519             call sc_grad
1520             endif
1521           enddo      ! j
1522         enddo        ! iint
1523       enddo          ! i
1524       return
1525       end
1526 C-----------------------------------------------------------------------------
1527       subroutine sc_angular
1528 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1529 C om12. Called by ebp, egb, and egbv.
1530       implicit none
1531       include 'COMMON.CALC'
1532       erij(1)=xj*rij
1533       erij(2)=yj*rij
1534       erij(3)=zj*rij
1535       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1536       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1537       om12=dxi*dxj+dyi*dyj+dzi*dzj
1538       chiom12=chi12*om12
1539 C Calculate eps1(om12) and its derivative in om12
1540       faceps1=1.0D0-om12*chiom12
1541       faceps1_inv=1.0D0/faceps1
1542       eps1=dsqrt(faceps1_inv)
1543 C Following variable is eps1*deps1/dom12
1544       eps1_om12=faceps1_inv*chiom12
1545 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1546 C and om12.
1547       om1om2=om1*om2
1548       chiom1=chi1*om1
1549       chiom2=chi2*om2
1550       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1551       sigsq=1.0D0-facsig*faceps1_inv
1552       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1553       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1554       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1555 C Calculate eps2 and its derivatives in om1, om2, and om12.
1556       chipom1=chip1*om1
1557       chipom2=chip2*om2
1558       chipom12=chip12*om12
1559       facp=1.0D0-om12*chipom12
1560       facp_inv=1.0D0/facp
1561       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1562 C Following variable is the square root of eps2
1563       eps2rt=1.0D0-facp1*facp_inv
1564 C Following three variables are the derivatives of the square root of eps
1565 C in om1, om2, and om12.
1566       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1567       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1568       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1569 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1570       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1571 C Calculate whole angle-dependent part of epsilon and contributions
1572 C to its derivatives
1573       return
1574       end
1575 C----------------------------------------------------------------------------
1576       subroutine sc_grad
1577       implicit real*8 (a-h,o-z)
1578       include 'DIMENSIONS'
1579       include 'DIMENSIONS.ZSCOPT'
1580       include 'COMMON.CHAIN'
1581       include 'COMMON.DERIV'
1582       include 'COMMON.CALC'
1583       double precision dcosom1(3),dcosom2(3)
1584       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1585       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1586       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1587      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1588       do k=1,3
1589         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1590         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1591       enddo
1592       do k=1,3
1593         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1594       enddo
1595       do k=1,3
1596         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1597      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1598      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1599         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1600      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1601      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1602       enddo
1603 C
1604 C Calculate the components of the gradient in DC and X
1605 C
1606       do k=i,j-1
1607         do l=1,3
1608           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1609         enddo
1610       enddo
1611       return
1612       end
1613 c------------------------------------------------------------------------------
1614       subroutine vec_and_deriv
1615       implicit real*8 (a-h,o-z)
1616       include 'DIMENSIONS'
1617       include 'DIMENSIONS.ZSCOPT'
1618       include 'COMMON.IOUNITS'
1619       include 'COMMON.GEO'
1620       include 'COMMON.VAR'
1621       include 'COMMON.LOCAL'
1622       include 'COMMON.CHAIN'
1623       include 'COMMON.VECTORS'
1624       include 'COMMON.DERIV'
1625       include 'COMMON.INTERACT'
1626       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1627 C Compute the local reference systems. For reference system (i), the
1628 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1629 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1630       do i=1,nres-1
1631 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1632           if (i.eq.nres-1) then
1633 C Case of the last full residue
1634 C Compute the Z-axis
1635             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1636             costh=dcos(pi-theta(nres))
1637             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1638 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1639 c     &         " uz",uz(:,i)
1640             do k=1,3
1641               uz(k,i)=fac*uz(k,i)
1642             enddo
1643             if (calc_grad) then
1644 C Compute the derivatives of uz
1645             uzder(1,1,1)= 0.0d0
1646             uzder(2,1,1)=-dc_norm(3,i-1)
1647             uzder(3,1,1)= dc_norm(2,i-1)
1648             uzder(1,2,1)= dc_norm(3,i-1)
1649             uzder(2,2,1)= 0.0d0
1650             uzder(3,2,1)=-dc_norm(1,i-1)
1651             uzder(1,3,1)=-dc_norm(2,i-1)
1652             uzder(2,3,1)= dc_norm(1,i-1)
1653             uzder(3,3,1)= 0.0d0
1654             uzder(1,1,2)= 0.0d0
1655             uzder(2,1,2)= dc_norm(3,i)
1656             uzder(3,1,2)=-dc_norm(2,i)
1657             uzder(1,2,2)=-dc_norm(3,i)
1658             uzder(2,2,2)= 0.0d0
1659             uzder(3,2,2)= dc_norm(1,i)
1660             uzder(1,3,2)= dc_norm(2,i)
1661             uzder(2,3,2)=-dc_norm(1,i)
1662             uzder(3,3,2)= 0.0d0
1663             endif ! calc_grad
1664 C Compute the Y-axis
1665             facy=fac
1666             do k=1,3
1667               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1668             enddo
1669             if (calc_grad) then
1670 C Compute the derivatives of uy
1671             do j=1,3
1672               do k=1,3
1673                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1674      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1675                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1676               enddo
1677               uyder(j,j,1)=uyder(j,j,1)-costh
1678               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1679             enddo
1680             do j=1,2
1681               do k=1,3
1682                 do l=1,3
1683                   uygrad(l,k,j,i)=uyder(l,k,j)
1684                   uzgrad(l,k,j,i)=uzder(l,k,j)
1685                 enddo
1686               enddo
1687             enddo
1688             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1689             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1690             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1691             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1692             endif
1693           else
1694 C Other residues
1695 C Compute the Z-axis
1696             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1697             costh=dcos(pi-theta(i+2))
1698             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1699             do k=1,3
1700               uz(k,i)=fac*uz(k,i)
1701             enddo
1702             if (calc_grad) then
1703 C Compute the derivatives of uz
1704             uzder(1,1,1)= 0.0d0
1705             uzder(2,1,1)=-dc_norm(3,i+1)
1706             uzder(3,1,1)= dc_norm(2,i+1)
1707             uzder(1,2,1)= dc_norm(3,i+1)
1708             uzder(2,2,1)= 0.0d0
1709             uzder(3,2,1)=-dc_norm(1,i+1)
1710             uzder(1,3,1)=-dc_norm(2,i+1)
1711             uzder(2,3,1)= dc_norm(1,i+1)
1712             uzder(3,3,1)= 0.0d0
1713             uzder(1,1,2)= 0.0d0
1714             uzder(2,1,2)= dc_norm(3,i)
1715             uzder(3,1,2)=-dc_norm(2,i)
1716             uzder(1,2,2)=-dc_norm(3,i)
1717             uzder(2,2,2)= 0.0d0
1718             uzder(3,2,2)= dc_norm(1,i)
1719             uzder(1,3,2)= dc_norm(2,i)
1720             uzder(2,3,2)=-dc_norm(1,i)
1721             uzder(3,3,2)= 0.0d0
1722             endif
1723 C Compute the Y-axis
1724             facy=fac
1725             do k=1,3
1726               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1727             enddo
1728             if (calc_grad) then
1729 C Compute the derivatives of uy
1730             do j=1,3
1731               do k=1,3
1732                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1733      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1734                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1735               enddo
1736               uyder(j,j,1)=uyder(j,j,1)-costh
1737               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1738             enddo
1739             do j=1,2
1740               do k=1,3
1741                 do l=1,3
1742                   uygrad(l,k,j,i)=uyder(l,k,j)
1743                   uzgrad(l,k,j,i)=uzder(l,k,j)
1744                 enddo
1745               enddo
1746             enddo
1747             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1748             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1749             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1750             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1751           endif
1752           endif
1753       enddo
1754       if (calc_grad) then
1755       do i=1,nres-1
1756         vbld_inv_temp(1)=vbld_inv(i+1)
1757         if (i.lt.nres-1) then
1758           vbld_inv_temp(2)=vbld_inv(i+2)
1759         else
1760           vbld_inv_temp(2)=vbld_inv(i)
1761         endif
1762         do j=1,2
1763           do k=1,3
1764             do l=1,3
1765               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1766               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1767             enddo
1768           enddo
1769         enddo
1770       enddo
1771       endif
1772       return
1773       end
1774 C--------------------------------------------------------------------------
1775       subroutine set_matrices
1776       implicit real*8 (a-h,o-z)
1777       include 'DIMENSIONS'
1778 #ifdef MPI
1779       include "mpif.h"
1780       integer IERR
1781       integer status(MPI_STATUS_SIZE)
1782 #endif
1783       include 'DIMENSIONS.ZSCOPT'
1784       include 'COMMON.IOUNITS'
1785       include 'COMMON.GEO'
1786       include 'COMMON.VAR'
1787       include 'COMMON.LOCAL'
1788       include 'COMMON.CHAIN'
1789       include 'COMMON.DERIV'
1790       include 'COMMON.INTERACT'
1791       include 'COMMON.CORRMAT'
1792       include 'COMMON.TORSION'
1793       include 'COMMON.VECTORS'
1794       include 'COMMON.FFIELD'
1795       double precision auxvec(2),auxmat(2,2)
1796 C
1797 C Compute the virtual-bond-torsional-angle dependent quantities needed
1798 C to calculate the el-loc multibody terms of various order.
1799 C
1800 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1801       do i=3,nres+1
1802         ii=ireschain(i-2)
1803         if (ii.eq.0) cycle
1804         innt=chain_border(1,ii)
1805         inct=chain_border(2,ii)
1806 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1807         if (i.gt. innt+2 .and. i.lt.inct+2) then
1808           iti = itype2loc(itype(i-2))
1809         else
1810           iti=nloctyp
1811         endif
1812 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1813 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1814         if (i.gt. innt+1 .and. i.lt.inct+1) then
1815           iti1 = itype2loc(itype(i-1))
1816         else
1817           iti1=nloctyp
1818         endif
1819 #ifdef NEWCORR
1820         cost1=dcos(theta(i-1))
1821         sint1=dsin(theta(i-1))
1822         sint1sq=sint1*sint1
1823         sint1cub=sint1sq*sint1
1824         sint1cost1=2*sint1*cost1
1825 #ifdef DEBUG
1826         write (iout,*) "bnew1",i,iti
1827         write (iout,*) (bnew1(k,1,iti),k=1,3)
1828         write (iout,*) (bnew1(k,2,iti),k=1,3)
1829         write (iout,*) "bnew2",i,iti
1830         write (iout,*) (bnew2(k,1,iti),k=1,3)
1831         write (iout,*) (bnew2(k,2,iti),k=1,3)
1832 #endif
1833         do k=1,2
1834           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1835           b1(k,i-2)=sint1*b1k
1836           gtb1(k,i-2)=cost1*b1k-sint1sq*
1837      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1838           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1839           b2(k,i-2)=sint1*b2k
1840           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1841      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1842         enddo
1843         do k=1,2
1844           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1845           cc(1,k,i-2)=sint1sq*aux
1846           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1847      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1848           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1849           dd(1,k,i-2)=sint1sq*aux
1850           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1851      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1852         enddo
1853         cc(2,1,i-2)=cc(1,2,i-2)
1854         cc(2,2,i-2)=-cc(1,1,i-2)
1855         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1856         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1857         dd(2,1,i-2)=dd(1,2,i-2)
1858         dd(2,2,i-2)=-dd(1,1,i-2)
1859         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1860         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1861         do k=1,2
1862           do l=1,2
1863             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1864             EE(l,k,i-2)=sint1sq*aux
1865             if (calc_grad)
1866      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1867           enddo
1868         enddo
1869         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1870         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1871         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1872         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1873         if (calc_grad) then
1874         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1875         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1876         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1877         endif
1878 c        b1tilde(1,i-2)=b1(1,i-2)
1879 c        b1tilde(2,i-2)=-b1(2,i-2)
1880 c        b2tilde(1,i-2)=b2(1,i-2)
1881 c        b2tilde(2,i-2)=-b2(2,i-2)
1882 #ifdef DEBUG
1883         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1884         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1885         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1886         write (iout,*) 'theta=', theta(i-1)
1887 #endif
1888 #else
1889 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1890 c          iti = itype2loc(itype(i-2))
1891 c        else
1892 c          iti=nloctyp
1893 c        endif
1894 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1895 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1896 c          iti1 = itype2loc(itype(i-1))
1897 c        else
1898 c          iti1=nloctyp
1899 c        endif
1900         b1(1,i-2)=b(3,iti)
1901         b1(2,i-2)=b(5,iti)
1902         b2(1,i-2)=b(2,iti)
1903         b2(2,i-2)=b(4,iti)
1904         do k=1,2
1905           do l=1,2
1906            CC(k,l,i-2)=ccold(k,l,iti)
1907            DD(k,l,i-2)=ddold(k,l,iti)
1908            EE(k,l,i-2)=eeold(k,l,iti)
1909           enddo
1910         enddo
1911 #endif
1912         b1tilde(1,i-2)= b1(1,i-2)
1913         b1tilde(2,i-2)=-b1(2,i-2)
1914         b2tilde(1,i-2)= b2(1,i-2)
1915         b2tilde(2,i-2)=-b2(2,i-2)
1916 c
1917         Ctilde(1,1,i-2)= CC(1,1,i-2)
1918         Ctilde(1,2,i-2)= CC(1,2,i-2)
1919         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1920         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1921 c
1922         Dtilde(1,1,i-2)= DD(1,1,i-2)
1923         Dtilde(1,2,i-2)= DD(1,2,i-2)
1924         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1925         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1926 #ifdef DEBUG
1927         write(iout,*) "i",i," iti",iti
1928         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1929         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1930 #endif
1931       enddo
1932       do i=3,nres+1
1933         if (i .lt. nres+1) then
1934           sin1=dsin(phi(i))
1935           cos1=dcos(phi(i))
1936           sintab(i-2)=sin1
1937           costab(i-2)=cos1
1938           obrot(1,i-2)=cos1
1939           obrot(2,i-2)=sin1
1940           sin2=dsin(2*phi(i))
1941           cos2=dcos(2*phi(i))
1942           sintab2(i-2)=sin2
1943           costab2(i-2)=cos2
1944           obrot2(1,i-2)=cos2
1945           obrot2(2,i-2)=sin2
1946           Ug(1,1,i-2)=-cos1
1947           Ug(1,2,i-2)=-sin1
1948           Ug(2,1,i-2)=-sin1
1949           Ug(2,2,i-2)= cos1
1950           Ug2(1,1,i-2)=-cos2
1951           Ug2(1,2,i-2)=-sin2
1952           Ug2(2,1,i-2)=-sin2
1953           Ug2(2,2,i-2)= cos2
1954         else
1955           costab(i-2)=1.0d0
1956           sintab(i-2)=0.0d0
1957           obrot(1,i-2)=1.0d0
1958           obrot(2,i-2)=0.0d0
1959           obrot2(1,i-2)=0.0d0
1960           obrot2(2,i-2)=0.0d0
1961           Ug(1,1,i-2)=1.0d0
1962           Ug(1,2,i-2)=0.0d0
1963           Ug(2,1,i-2)=0.0d0
1964           Ug(2,2,i-2)=1.0d0
1965           Ug2(1,1,i-2)=0.0d0
1966           Ug2(1,2,i-2)=0.0d0
1967           Ug2(2,1,i-2)=0.0d0
1968           Ug2(2,2,i-2)=0.0d0
1969         endif
1970         if (i .gt. 3 .and. i .lt. nres+1) then
1971           obrot_der(1,i-2)=-sin1
1972           obrot_der(2,i-2)= cos1
1973           Ugder(1,1,i-2)= sin1
1974           Ugder(1,2,i-2)=-cos1
1975           Ugder(2,1,i-2)=-cos1
1976           Ugder(2,2,i-2)=-sin1
1977           dwacos2=cos2+cos2
1978           dwasin2=sin2+sin2
1979           obrot2_der(1,i-2)=-dwasin2
1980           obrot2_der(2,i-2)= dwacos2
1981           Ug2der(1,1,i-2)= dwasin2
1982           Ug2der(1,2,i-2)=-dwacos2
1983           Ug2der(2,1,i-2)=-dwacos2
1984           Ug2der(2,2,i-2)=-dwasin2
1985         else
1986           obrot_der(1,i-2)=0.0d0
1987           obrot_der(2,i-2)=0.0d0
1988           Ugder(1,1,i-2)=0.0d0
1989           Ugder(1,2,i-2)=0.0d0
1990           Ugder(2,1,i-2)=0.0d0
1991           Ugder(2,2,i-2)=0.0d0
1992           obrot2_der(1,i-2)=0.0d0
1993           obrot2_der(2,i-2)=0.0d0
1994           Ug2der(1,1,i-2)=0.0d0
1995           Ug2der(1,2,i-2)=0.0d0
1996           Ug2der(2,1,i-2)=0.0d0
1997           Ug2der(2,2,i-2)=0.0d0
1998         endif
1999 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2000         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2001           iti = itype2loc(itype(i-2))
2002         else
2003           iti=nloctyp
2004         endif
2005 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2006         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2007           iti1 = itype2loc(itype(i-1))
2008         else
2009           iti1=nloctyp
2010         endif
2011 cd        write (iout,*) '*******i',i,' iti1',iti
2012 cd        write (iout,*) 'b1',b1(:,iti)
2013 cd        write (iout,*) 'b2',b2(:,iti)
2014 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2015 c        if (i .gt. iatel_s+2) then
2016         if (i .gt. nnt+2) then
2017           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2018 #ifdef NEWCORR
2019           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2020 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2021 #endif
2022 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2023 c     &    EE(1,2,iti),EE(2,2,i)
2024           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2025           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2026 c          write(iout,*) "Macierz EUG",
2027 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2028 c     &    eug(2,2,i-2)
2029 #ifdef FOURBODY
2030           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2031      &    then
2032           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2033           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2034           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2035           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2036           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2037           endif
2038 #endif
2039         else
2040           do k=1,2
2041             Ub2(k,i-2)=0.0d0
2042             Ctobr(k,i-2)=0.0d0
2043             Dtobr2(k,i-2)=0.0d0
2044             do l=1,2
2045               EUg(l,k,i-2)=0.0d0
2046               CUg(l,k,i-2)=0.0d0
2047               DUg(l,k,i-2)=0.0d0
2048               DtUg2(l,k,i-2)=0.0d0
2049             enddo
2050           enddo
2051         endif
2052         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2053         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2054         do k=1,2
2055           muder(k,i-2)=Ub2der(k,i-2)
2056         enddo
2057 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2058         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2059           if (itype(i-1).le.ntyp) then
2060             iti1 = itype2loc(itype(i-1))
2061           else
2062             iti1=nloctyp
2063           endif
2064         else
2065           iti1=nloctyp
2066         endif
2067         do k=1,2
2068           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2069         enddo
2070 #ifdef MUOUT
2071         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2072      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2073      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2074      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2075      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2076      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2077 #endif
2078 cd        write (iout,*) 'mu1',mu1(:,i-2)
2079 cd        write (iout,*) 'mu2',mu2(:,i-2)
2080 #ifdef FOURBODY
2081         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2082      &  then
2083         if (calc_grad) then
2084         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2085         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2086         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2087         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2088         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2089         endif
2090 C Vectors and matrices dependent on a single virtual-bond dihedral.
2091         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2092         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2093         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2094         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2095         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2096         if (calc_grad) then
2097         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2098         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2099         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2100         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2101         endif
2102         endif
2103 #endif
2104       enddo
2105 #ifdef FOURBODY
2106 C Matrices dependent on two consecutive virtual-bond dihedrals.
2107 C The order of matrices is from left to right.
2108       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2109      &then
2110       do i=2,nres-1
2111         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2112         if (calc_grad) then
2113         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2114         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2115         endif
2116         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2117         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2118         if (calc_grad) then
2119         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2120         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2121         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2122         endif
2123       enddo
2124       endif
2125 #endif
2126       return
2127       end
2128 C--------------------------------------------------------------------------
2129       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2130 C
2131 C This subroutine calculates the average interaction energy and its gradient
2132 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2133 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2134 C The potential depends both on the distance of peptide-group centers and on
2135 C the orientation of the CA-CA virtual bonds.
2136 C
2137       implicit real*8 (a-h,o-z)
2138 #ifdef MPI
2139       include 'mpif.h'
2140 #endif
2141       include 'DIMENSIONS'
2142       include 'DIMENSIONS.ZSCOPT'
2143       include 'COMMON.CONTROL'
2144       include 'COMMON.IOUNITS'
2145       include 'COMMON.GEO'
2146       include 'COMMON.VAR'
2147       include 'COMMON.LOCAL'
2148       include 'COMMON.CHAIN'
2149       include 'COMMON.DERIV'
2150       include 'COMMON.INTERACT'
2151 #ifdef FOURBODY
2152       include 'COMMON.CONTACTS'
2153       include 'COMMON.CONTMAT'
2154 #endif
2155       include 'COMMON.CORRMAT'
2156       include 'COMMON.TORSION'
2157       include 'COMMON.VECTORS'
2158       include 'COMMON.FFIELD'
2159       include 'COMMON.TIME1'
2160       include 'COMMON.SPLITELE'
2161       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2162      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2163       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2164      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2165       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2166      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2167      &    num_conti,j1,j2
2168 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2169 #ifdef MOMENT
2170       double precision scal_el /1.0d0/
2171 #else
2172       double precision scal_el /0.5d0/
2173 #endif
2174 C 12/13/98
2175 C 13-go grudnia roku pamietnego...
2176       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2177      &                   0.0d0,1.0d0,0.0d0,
2178      &                   0.0d0,0.0d0,1.0d0/
2179 cd      write(iout,*) 'In EELEC'
2180 cd      do i=1,nloctyp
2181 cd        write(iout,*) 'Type',i
2182 cd        write(iout,*) 'B1',B1(:,i)
2183 cd        write(iout,*) 'B2',B2(:,i)
2184 cd        write(iout,*) 'CC',CC(:,:,i)
2185 cd        write(iout,*) 'DD',DD(:,:,i)
2186 cd        write(iout,*) 'EE',EE(:,:,i)
2187 cd      enddo
2188 cd      call check_vecgrad
2189 cd      stop
2190       if (icheckgrad.eq.1) then
2191         do i=1,nres-1
2192           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2193           do k=1,3
2194             dc_norm(k,i)=dc(k,i)*fac
2195           enddo
2196 c          write (iout,*) 'i',i,' fac',fac
2197         enddo
2198       endif
2199       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2200      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2201      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2202 c        call vec_and_deriv
2203 #ifdef TIMING
2204         time01=MPI_Wtime()
2205 #endif
2206         call set_matrices
2207 #ifdef TIMING
2208         time_mat=time_mat+MPI_Wtime()-time01
2209 #endif
2210       endif
2211 cd      do i=1,nres-1
2212 cd        write (iout,*) 'i=',i
2213 cd        do k=1,3
2214 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2215 cd        enddo
2216 cd        do k=1,3
2217 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2218 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2219 cd        enddo
2220 cd      enddo
2221       t_eelecij=0.0d0
2222       ees=0.0D0
2223       evdw1=0.0D0
2224       eel_loc=0.0d0
2225       eello_turn3=0.0d0
2226       eello_turn4=0.0d0
2227       ind=0
2228 #ifdef FOURBODY
2229       do i=1,nres
2230         num_cont_hb(i)=0
2231       enddo
2232 #endif
2233 cd      print '(a)','Enter EELEC'
2234 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2235       do i=1,nres
2236         gel_loc_loc(i)=0.0d0
2237         gcorr_loc(i)=0.0d0
2238       enddo
2239 c
2240 c
2241 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2242 C
2243 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2244 C
2245 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2246       do i=iturn3_start,iturn3_end
2247 c        if (i.le.1) cycle
2248 C        write(iout,*) "tu jest i",i
2249         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2250 C changes suggested by Ana to avoid out of bounds
2251 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2252 c     & .or.((i+4).gt.nres)
2253 c     & .or.((i-1).le.0)
2254 C end of changes by Ana
2255 C dobra zmiana wycofana
2256      &  .or. itype(i+2).eq.ntyp1
2257      &  .or. itype(i+3).eq.ntyp1) cycle
2258 C Adam: Instructions below will switch off existing interactions
2259 c        if(i.gt.1)then
2260 c          if(itype(i-1).eq.ntyp1)cycle
2261 c        end if
2262 c        if(i.LT.nres-3)then
2263 c          if (itype(i+4).eq.ntyp1) cycle
2264 c        end if
2265         dxi=dc(1,i)
2266         dyi=dc(2,i)
2267         dzi=dc(3,i)
2268         dx_normi=dc_norm(1,i)
2269         dy_normi=dc_norm(2,i)
2270         dz_normi=dc_norm(3,i)
2271         xmedi=c(1,i)+0.5d0*dxi
2272         ymedi=c(2,i)+0.5d0*dyi
2273         zmedi=c(3,i)+0.5d0*dzi
2274           xmedi=mod(xmedi,boxxsize)
2275           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2276           ymedi=mod(ymedi,boxysize)
2277           if (ymedi.lt.0) ymedi=ymedi+boxysize
2278           zmedi=mod(zmedi,boxzsize)
2279           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2280         num_conti=0
2281         call eelecij(i,i+2,ees,evdw1,eel_loc)
2282         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2283 #ifdef FOURBODY
2284         num_cont_hb(i)=num_conti
2285 #endif
2286       enddo
2287       do i=iturn4_start,iturn4_end
2288         if (i.lt.1) cycle
2289         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2290 C changes suggested by Ana to avoid out of bounds
2291 c     & .or.((i+5).gt.nres)
2292 c     & .or.((i-1).le.0)
2293 C end of changes suggested by Ana
2294      &    .or. itype(i+3).eq.ntyp1
2295      &    .or. itype(i+4).eq.ntyp1
2296 c     &    .or. itype(i+5).eq.ntyp1
2297 c     &    .or. itype(i).eq.ntyp1
2298 c     &    .or. itype(i-1).eq.ntyp1
2299      &                             ) cycle
2300         dxi=dc(1,i)
2301         dyi=dc(2,i)
2302         dzi=dc(3,i)
2303         dx_normi=dc_norm(1,i)
2304         dy_normi=dc_norm(2,i)
2305         dz_normi=dc_norm(3,i)
2306         xmedi=c(1,i)+0.5d0*dxi
2307         ymedi=c(2,i)+0.5d0*dyi
2308         zmedi=c(3,i)+0.5d0*dzi
2309 C Return atom into box, boxxsize is size of box in x dimension
2310 c  194   continue
2311 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2312 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2313 C Condition for being inside the proper box
2314 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2315 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2316 c        go to 194
2317 c        endif
2318 c  195   continue
2319 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2320 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2321 C Condition for being inside the proper box
2322 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2323 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2324 c        go to 195
2325 c        endif
2326 c  196   continue
2327 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2328 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2329 C Condition for being inside the proper box
2330 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2331 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2332 c        go to 196
2333 c        endif
2334           xmedi=mod(xmedi,boxxsize)
2335           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2336           ymedi=mod(ymedi,boxysize)
2337           if (ymedi.lt.0) ymedi=ymedi+boxysize
2338           zmedi=mod(zmedi,boxzsize)
2339           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2340 #ifdef FOURBODY
2341         num_conti=num_cont_hb(i)
2342 #endif
2343 c        write(iout,*) "JESTEM W PETLI"
2344         call eelecij(i,i+3,ees,evdw1,eel_loc)
2345         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2346      &   call eturn4(i,eello_turn4)
2347 #ifdef FOURBODY
2348         num_cont_hb(i)=num_conti
2349 #endif
2350       enddo   ! i
2351 C Loop over all neighbouring boxes
2352 C      do xshift=-1,1
2353 C      do yshift=-1,1
2354 C      do zshift=-1,1
2355 c
2356 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2357 c
2358 CTU KURWA
2359       do i=iatel_s,iatel_e
2360 C        do i=75,75
2361 c        if (i.le.1) cycle
2362         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2363 C changes suggested by Ana to avoid out of bounds
2364 c     & .or.((i+2).gt.nres)
2365 c     & .or.((i-1).le.0)
2366 C end of changes by Ana
2367 c     &  .or. itype(i+2).eq.ntyp1
2368 c     &  .or. itype(i-1).eq.ntyp1
2369      &                ) cycle
2370         dxi=dc(1,i)
2371         dyi=dc(2,i)
2372         dzi=dc(3,i)
2373         dx_normi=dc_norm(1,i)
2374         dy_normi=dc_norm(2,i)
2375         dz_normi=dc_norm(3,i)
2376         xmedi=c(1,i)+0.5d0*dxi
2377         ymedi=c(2,i)+0.5d0*dyi
2378         zmedi=c(3,i)+0.5d0*dzi
2379           xmedi=mod(xmedi,boxxsize)
2380           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2381           ymedi=mod(ymedi,boxysize)
2382           if (ymedi.lt.0) ymedi=ymedi+boxysize
2383           zmedi=mod(zmedi,boxzsize)
2384           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2385 C          xmedi=xmedi+xshift*boxxsize
2386 C          ymedi=ymedi+yshift*boxysize
2387 C          zmedi=zmedi+zshift*boxzsize
2388
2389 C Return tom into box, boxxsize is size of box in x dimension
2390 c  164   continue
2391 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2392 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2393 C Condition for being inside the proper box
2394 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2395 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2396 c        go to 164
2397 c        endif
2398 c  165   continue
2399 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2400 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2401 C Condition for being inside the proper box
2402 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2403 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2404 c        go to 165
2405 c        endif
2406 c  166   continue
2407 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2408 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2409 cC Condition for being inside the proper box
2410 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2411 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2412 c        go to 166
2413 c        endif
2414
2415 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2416 #ifdef FOURBODY
2417         num_conti=num_cont_hb(i)
2418 #endif
2419 C I TU KURWA
2420         do j=ielstart(i),ielend(i)
2421 C          do j=16,17
2422 C          write (iout,*) i,j
2423 C         if (j.le.1) cycle
2424           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2425 C changes suggested by Ana to avoid out of bounds
2426 c     & .or.((j+2).gt.nres)
2427 c     & .or.((j-1).le.0)
2428 C end of changes by Ana
2429 c     & .or.itype(j+2).eq.ntyp1
2430 c     & .or.itype(j-1).eq.ntyp1
2431      &) cycle
2432           call eelecij(i,j,ees,evdw1,eel_loc)
2433         enddo ! j
2434 #ifdef FOURBODY
2435         num_cont_hb(i)=num_conti
2436 #endif
2437       enddo   ! i
2438 C     enddo   ! zshift
2439 C      enddo   ! yshift
2440 C      enddo   ! xshift
2441
2442 c      write (iout,*) "Number of loop steps in EELEC:",ind
2443 cd      do i=1,nres
2444 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2445 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2446 cd      enddo
2447 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2448 ccc      eel_loc=eel_loc+eello_turn3
2449 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2450       return
2451       end
2452 C-------------------------------------------------------------------------------
2453       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2454       implicit real*8 (a-h,o-z)
2455       include 'DIMENSIONS'
2456       include 'DIMENSIONS.ZSCOPT'
2457 #ifdef MPI
2458       include "mpif.h"
2459 #endif
2460       include 'COMMON.CONTROL'
2461       include 'COMMON.IOUNITS'
2462       include 'COMMON.GEO'
2463       include 'COMMON.VAR'
2464       include 'COMMON.LOCAL'
2465       include 'COMMON.CHAIN'
2466       include 'COMMON.DERIV'
2467       include 'COMMON.INTERACT'
2468 #ifdef FOURBODY
2469       include 'COMMON.CONTACTS'
2470       include 'COMMON.CONTMAT'
2471 #endif
2472       include 'COMMON.CORRMAT'
2473       include 'COMMON.TORSION'
2474       include 'COMMON.VECTORS'
2475       include 'COMMON.FFIELD'
2476       include 'COMMON.TIME1'
2477       include 'COMMON.SPLITELE'
2478       include 'COMMON.SHIELD'
2479       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2480      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2481       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2482      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2483      &    gmuij2(4),gmuji2(4)
2484       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2485      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2486      &    num_conti,j1,j2
2487 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2488 #ifdef MOMENT
2489       double precision scal_el /1.0d0/
2490 #else
2491       double precision scal_el /0.5d0/
2492 #endif
2493 C 12/13/98
2494 C 13-go grudnia roku pamietnego...
2495       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2496      &                   0.0d0,1.0d0,0.0d0,
2497      &                   0.0d0,0.0d0,1.0d0/
2498        integer xshift,yshift,zshift
2499 c          time00=MPI_Wtime()
2500 cd      write (iout,*) "eelecij",i,j
2501 c          ind=ind+1
2502           iteli=itel(i)
2503           itelj=itel(j)
2504           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2505           aaa=app(iteli,itelj)
2506           bbb=bpp(iteli,itelj)
2507           ael6i=ael6(iteli,itelj)
2508           ael3i=ael3(iteli,itelj)
2509           dxj=dc(1,j)
2510           dyj=dc(2,j)
2511           dzj=dc(3,j)
2512           dx_normj=dc_norm(1,j)
2513           dy_normj=dc_norm(2,j)
2514           dz_normj=dc_norm(3,j)
2515 C          xj=c(1,j)+0.5D0*dxj-xmedi
2516 C          yj=c(2,j)+0.5D0*dyj-ymedi
2517 C          zj=c(3,j)+0.5D0*dzj-zmedi
2518           xj=c(1,j)+0.5D0*dxj
2519           yj=c(2,j)+0.5D0*dyj
2520           zj=c(3,j)+0.5D0*dzj
2521           xj=mod(xj,boxxsize)
2522           if (xj.lt.0) xj=xj+boxxsize
2523           yj=mod(yj,boxysize)
2524           if (yj.lt.0) yj=yj+boxysize
2525           zj=mod(zj,boxzsize)
2526           if (zj.lt.0) zj=zj+boxzsize
2527           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2528       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2529       xj_safe=xj
2530       yj_safe=yj
2531       zj_safe=zj
2532       isubchap=0
2533       do xshift=-1,1
2534       do yshift=-1,1
2535       do zshift=-1,1
2536           xj=xj_safe+xshift*boxxsize
2537           yj=yj_safe+yshift*boxysize
2538           zj=zj_safe+zshift*boxzsize
2539           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2540           if(dist_temp.lt.dist_init) then
2541             dist_init=dist_temp
2542             xj_temp=xj
2543             yj_temp=yj
2544             zj_temp=zj
2545             isubchap=1
2546           endif
2547        enddo
2548        enddo
2549        enddo
2550        if (isubchap.eq.1) then
2551           xj=xj_temp-xmedi
2552           yj=yj_temp-ymedi
2553           zj=zj_temp-zmedi
2554        else
2555           xj=xj_safe-xmedi
2556           yj=yj_safe-ymedi
2557           zj=zj_safe-zmedi
2558        endif
2559 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2560 c  174   continue
2561 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2562 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2563 C Condition for being inside the proper box
2564 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2565 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2566 c        go to 174
2567 c        endif
2568 c  175   continue
2569 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2570 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2571 C Condition for being inside the proper box
2572 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2573 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2574 c        go to 175
2575 c        endif
2576 c  176   continue
2577 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2578 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2579 C Condition for being inside the proper box
2580 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2581 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2582 c        go to 176
2583 c        endif
2584 C        endif !endPBC condintion
2585 C        xj=xj-xmedi
2586 C        yj=yj-ymedi
2587 C        zj=zj-zmedi
2588           rij=xj*xj+yj*yj+zj*zj
2589
2590           sss=sscale(sqrt(rij))
2591           if (sss.eq.0.0d0) return
2592           sssgrad=sscagrad(sqrt(rij))
2593 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2594 c     &       " rlamb",rlamb," sss",sss
2595 c            if (sss.gt.0.0d0) then
2596           rrmij=1.0D0/rij
2597           rij=dsqrt(rij)
2598           rmij=1.0D0/rij
2599           r3ij=rrmij*rmij
2600           r6ij=r3ij*r3ij
2601           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2602           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2603           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2604           fac=cosa-3.0D0*cosb*cosg
2605           ev1=aaa*r6ij*r6ij
2606 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2607           if (j.eq.i+2) ev1=scal_el*ev1
2608           ev2=bbb*r6ij
2609           fac3=ael6i*r6ij
2610           fac4=ael3i*r3ij
2611           evdwij=(ev1+ev2)
2612           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2613           el2=fac4*fac
2614 C MARYSIA
2615 C          eesij=(el1+el2)
2616 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2617           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2618           if (shield_mode.gt.0) then
2619 C          fac_shield(i)=0.4
2620 C          fac_shield(j)=0.6
2621           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2622           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2623           eesij=(el1+el2)
2624           ees=ees+eesij
2625           else
2626           fac_shield(i)=1.0
2627           fac_shield(j)=1.0
2628           eesij=(el1+el2)
2629           ees=ees+eesij
2630           endif
2631           evdw1=evdw1+evdwij*sss
2632 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2633 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2634 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2635 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2636
2637           if (energy_dec) then
2638               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2639      &'evdw1',i,j,evdwij
2640      &,iteli,itelj,aaa,evdw1,sss
2641               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2642      &fac_shield(i),fac_shield(j)
2643           endif
2644
2645 C
2646 C Calculate contributions to the Cartesian gradient.
2647 C
2648 #ifdef SPLITELE
2649           facvdw=-6*rrmij*(ev1+evdwij)*sss
2650           facel=-3*rrmij*(el1+eesij)
2651           fac1=fac
2652           erij(1)=xj*rmij
2653           erij(2)=yj*rmij
2654           erij(3)=zj*rmij
2655
2656 *
2657 * Radial derivatives. First process both termini of the fragment (i,j)
2658 *
2659           if (calc_grad) then
2660           ggg(1)=facel*xj
2661           ggg(2)=facel*yj
2662           ggg(3)=facel*zj
2663           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2664      &  (shield_mode.gt.0)) then
2665 C          print *,i,j
2666           do ilist=1,ishield_list(i)
2667            iresshield=shield_list(ilist,i)
2668            do k=1,3
2669            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2670      &      *2.0
2671            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2672      &              rlocshield
2673      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2674             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2675 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2676 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2677 C             if (iresshield.gt.i) then
2678 C               do ishi=i+1,iresshield-1
2679 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2680 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2681 C
2682 C              enddo
2683 C             else
2684 C               do ishi=iresshield,i
2685 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2686 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2687 C
2688 C               enddo
2689 C              endif
2690            enddo
2691           enddo
2692           do ilist=1,ishield_list(j)
2693            iresshield=shield_list(ilist,j)
2694            do k=1,3
2695            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2696      &     *2.0
2697            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2698      &              rlocshield
2699      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2700            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2701
2702 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2703 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2704 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2705 C             if (iresshield.gt.j) then
2706 C               do ishi=j+1,iresshield-1
2707 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2708 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2709 C
2710 C               enddo
2711 C            else
2712 C               do ishi=iresshield,j
2713 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2714 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2715 C               enddo
2716 C              endif
2717            enddo
2718           enddo
2719
2720           do k=1,3
2721             gshieldc(k,i)=gshieldc(k,i)+
2722      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2723             gshieldc(k,j)=gshieldc(k,j)+
2724      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2725             gshieldc(k,i-1)=gshieldc(k,i-1)+
2726      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2727             gshieldc(k,j-1)=gshieldc(k,j-1)+
2728      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2729
2730            enddo
2731            endif
2732 c          do k=1,3
2733 c            ghalf=0.5D0*ggg(k)
2734 c            gelc(k,i)=gelc(k,i)+ghalf
2735 c            gelc(k,j)=gelc(k,j)+ghalf
2736 c          enddo
2737 c 9/28/08 AL Gradient compotents will be summed only at the end
2738 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2739           do k=1,3
2740             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2741 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2742             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2743 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2744 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2745 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2746 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2747 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2748           enddo
2749 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2750
2751 *
2752 * Loop over residues i+1 thru j-1.
2753 *
2754 cgrad          do k=i+1,j-1
2755 cgrad            do l=1,3
2756 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2757 cgrad            enddo
2758 cgrad          enddo
2759           if (sss.gt.0.0) then
2760           facvdw=facvdw+sssgrad*rmij*evdwij
2761           ggg(1)=facvdw*xj
2762           ggg(2)=facvdw*yj
2763           ggg(3)=facvdw*zj
2764           else
2765           ggg(1)=0.0
2766           ggg(2)=0.0
2767           ggg(3)=0.0
2768           endif
2769 c          do k=1,3
2770 c            ghalf=0.5D0*ggg(k)
2771 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2772 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2773 c          enddo
2774 c 9/28/08 AL Gradient compotents will be summed only at the end
2775           do k=1,3
2776             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2778           enddo
2779 *
2780 * Loop over residues i+1 thru j-1.
2781 *
2782 cgrad          do k=i+1,j-1
2783 cgrad            do l=1,3
2784 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2785 cgrad            enddo
2786 cgrad          enddo
2787           endif ! calc_grad
2788 #else
2789 C MARYSIA
2790           facvdw=(ev1+evdwij)
2791           facel=(el1+eesij)
2792           fac1=fac
2793           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2794      &       +(evdwij+eesij)*sssgrad*rrmij
2795           erij(1)=xj*rmij
2796           erij(2)=yj*rmij
2797           erij(3)=zj*rmij
2798 *
2799 * Radial derivatives. First process both termini of the fragment (i,j)
2800 *
2801           if (calc_grad) then
2802           ggg(1)=fac*xj
2803 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2804           ggg(2)=fac*yj
2805 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2806           ggg(3)=fac*zj
2807 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2808 c          do k=1,3
2809 c            ghalf=0.5D0*ggg(k)
2810 c            gelc(k,i)=gelc(k,i)+ghalf
2811 c            gelc(k,j)=gelc(k,j)+ghalf
2812 c          enddo
2813 c 9/28/08 AL Gradient compotents will be summed only at the end
2814           do k=1,3
2815             gelc_long(k,j)=gelc(k,j)+ggg(k)
2816             gelc_long(k,i)=gelc(k,i)-ggg(k)
2817           enddo
2818 *
2819 * Loop over residues i+1 thru j-1.
2820 *
2821 cgrad          do k=i+1,j-1
2822 cgrad            do l=1,3
2823 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2824 cgrad            enddo
2825 cgrad          enddo
2826 c 9/28/08 AL Gradient compotents will be summed only at the end
2827           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2828           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2829           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2830           do k=1,3
2831             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2832             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2833           enddo
2834           endif ! calc_grad
2835 #endif
2836 *
2837 * Angular part
2838 *
2839           if (calc_grad) then
2840           ecosa=2.0D0*fac3*fac1+fac4
2841           fac4=-3.0D0*fac4
2842           fac3=-6.0D0*fac3
2843           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2844           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2845           do k=1,3
2846             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2847             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2848           enddo
2849 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2850 cd   &          (dcosg(k),k=1,3)
2851           do k=1,3
2852             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2853      &      fac_shield(i)**2*fac_shield(j)**2
2854           enddo
2855 c          do k=1,3
2856 c            ghalf=0.5D0*ggg(k)
2857 c            gelc(k,i)=gelc(k,i)+ghalf
2858 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2859 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2860 c            gelc(k,j)=gelc(k,j)+ghalf
2861 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2862 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2863 c          enddo
2864 cgrad          do k=i+1,j-1
2865 cgrad            do l=1,3
2866 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2867 cgrad            enddo
2868 cgrad          enddo
2869 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2870           do k=1,3
2871             gelc(k,i)=gelc(k,i)
2872      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2873      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2874      &           *fac_shield(i)**2*fac_shield(j)**2
2875             gelc(k,j)=gelc(k,j)
2876      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2877      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2878      &           *fac_shield(i)**2*fac_shield(j)**2
2879             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2880             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2881           enddo
2882 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2883
2884 C MARYSIA
2885 c          endif !sscale
2886           endif ! calc_grad
2887           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2888      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2889      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2890 C
2891 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2892 C   energy of a peptide unit is assumed in the form of a second-order
2893 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2894 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2895 C   are computed for EVERY pair of non-contiguous peptide groups.
2896 C
2897
2898           if (j.lt.nres-1) then
2899             j1=j+1
2900             j2=j-1
2901           else
2902             j1=j-1
2903             j2=j-2
2904           endif
2905           kkk=0
2906           lll=0
2907           do k=1,2
2908             do l=1,2
2909               kkk=kkk+1
2910               muij(kkk)=mu(k,i)*mu(l,j)
2911 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2912 #ifdef NEWCORR
2913              if (calc_grad) then
2914              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2915 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2916              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2917              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2918 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2919              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2920              endif
2921 #endif
2922             enddo
2923           enddo
2924 #ifdef DEBUG
2925           write (iout,*) 'EELEC: i',i,' j',j
2926           write (iout,*) 'j',j,' j1',j1,' j2',j2
2927           write(iout,*) 'muij',muij
2928           write (iout,*) "uy",uy(:,i)
2929           write (iout,*) "uz",uz(:,j)
2930           write (iout,*) "erij",erij
2931 #endif
2932           ury=scalar(uy(1,i),erij)
2933           urz=scalar(uz(1,i),erij)
2934           vry=scalar(uy(1,j),erij)
2935           vrz=scalar(uz(1,j),erij)
2936           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2937           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2938           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2939           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2940           fac=dsqrt(-ael6i)*r3ij
2941           a22=a22*fac
2942           a23=a23*fac
2943           a32=a32*fac
2944           a33=a33*fac
2945 cd          write (iout,'(4i5,4f10.5)')
2946 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2947 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2948 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2949 cd     &      uy(:,j),uz(:,j)
2950 cd          write (iout,'(4f10.5)')
2951 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2952 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2953 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2954 cd           write (iout,'(9f10.5/)')
2955 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2956 C Derivatives of the elements of A in virtual-bond vectors
2957           if (calc_grad) then
2958           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2959           do k=1,3
2960             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2961             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2962             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2963             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2964             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2965             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2966             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2967             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2968             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2969             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2970             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2971             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2972           enddo
2973 C Compute radial contributions to the gradient
2974           facr=-3.0d0*rrmij
2975           a22der=a22*facr
2976           a23der=a23*facr
2977           a32der=a32*facr
2978           a33der=a33*facr
2979           agg(1,1)=a22der*xj
2980           agg(2,1)=a22der*yj
2981           agg(3,1)=a22der*zj
2982           agg(1,2)=a23der*xj
2983           agg(2,2)=a23der*yj
2984           agg(3,2)=a23der*zj
2985           agg(1,3)=a32der*xj
2986           agg(2,3)=a32der*yj
2987           agg(3,3)=a32der*zj
2988           agg(1,4)=a33der*xj
2989           agg(2,4)=a33der*yj
2990           agg(3,4)=a33der*zj
2991 C Add the contributions coming from er
2992           fac3=-3.0d0*fac
2993           do k=1,3
2994             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2995             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2996             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2997             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2998           enddo
2999           do k=1,3
3000 C Derivatives in DC(i)
3001 cgrad            ghalf1=0.5d0*agg(k,1)
3002 cgrad            ghalf2=0.5d0*agg(k,2)
3003 cgrad            ghalf3=0.5d0*agg(k,3)
3004 cgrad            ghalf4=0.5d0*agg(k,4)
3005             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3006      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3007             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3008      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3009             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3010      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3011             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3012      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3013 C Derivatives in DC(i+1)
3014             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3015      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3016             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3017      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3018             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3019      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3020             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3021      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3022 C Derivatives in DC(j)
3023             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3024      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3025             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3026      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3027             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3028      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3029             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3030      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3031 C Derivatives in DC(j+1) or DC(nres-1)
3032             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3033      &      -3.0d0*vryg(k,3)*ury)
3034             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3035      &      -3.0d0*vrzg(k,3)*ury)
3036             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3037      &      -3.0d0*vryg(k,3)*urz)
3038             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3039      &      -3.0d0*vrzg(k,3)*urz)
3040 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3041 cgrad              do l=1,4
3042 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3043 cgrad              enddo
3044 cgrad            endif
3045           enddo
3046           endif ! calc_grad
3047           acipa(1,1)=a22
3048           acipa(1,2)=a23
3049           acipa(2,1)=a32
3050           acipa(2,2)=a33
3051           a22=-a22
3052           a23=-a23
3053           if (calc_grad) then
3054           do l=1,2
3055             do k=1,3
3056               agg(k,l)=-agg(k,l)
3057               aggi(k,l)=-aggi(k,l)
3058               aggi1(k,l)=-aggi1(k,l)
3059               aggj(k,l)=-aggj(k,l)
3060               aggj1(k,l)=-aggj1(k,l)
3061             enddo
3062           enddo
3063           endif ! calc_grad
3064           if (j.lt.nres-1) then
3065             a22=-a22
3066             a32=-a32
3067             do l=1,3,2
3068               do k=1,3
3069                 agg(k,l)=-agg(k,l)
3070                 aggi(k,l)=-aggi(k,l)
3071                 aggi1(k,l)=-aggi1(k,l)
3072                 aggj(k,l)=-aggj(k,l)
3073                 aggj1(k,l)=-aggj1(k,l)
3074               enddo
3075             enddo
3076           else
3077             a22=-a22
3078             a23=-a23
3079             a32=-a32
3080             a33=-a33
3081             do l=1,4
3082               do k=1,3
3083                 agg(k,l)=-agg(k,l)
3084                 aggi(k,l)=-aggi(k,l)
3085                 aggi1(k,l)=-aggi1(k,l)
3086                 aggj(k,l)=-aggj(k,l)
3087                 aggj1(k,l)=-aggj1(k,l)
3088               enddo
3089             enddo
3090           endif
3091           ENDIF ! WCORR
3092           IF (wel_loc.gt.0.0d0) THEN
3093 C Contribution to the local-electrostatic energy coming from the i-j pair
3094           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3095      &     +a33*muij(4)
3096 #ifdef DEBUG
3097           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3098      &     " a33",a33
3099           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3100      &     " wel_loc",wel_loc
3101 #endif
3102           if (shield_mode.eq.0) then
3103            fac_shield(i)=1.0
3104            fac_shield(j)=1.0
3105 C          else
3106 C           fac_shield(i)=0.4
3107 C           fac_shield(j)=0.6
3108           endif
3109           eel_loc_ij=eel_loc_ij
3110      &    *fac_shield(i)*fac_shield(j)*sss
3111           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3112      &            'eelloc',i,j,eel_loc_ij
3113 c           if (eel_loc_ij.ne.0)
3114 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3115 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3116
3117           eel_loc=eel_loc+eel_loc_ij
3118 C Now derivative over eel_loc
3119           if (calc_grad) then
3120           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3121      &  (shield_mode.gt.0)) then
3122 C          print *,i,j
3123
3124           do ilist=1,ishield_list(i)
3125            iresshield=shield_list(ilist,i)
3126            do k=1,3
3127            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3128      &                                          /fac_shield(i)
3129 C     &      *2.0
3130            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3131      &              rlocshield
3132      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3133             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3134      &      +rlocshield
3135            enddo
3136           enddo
3137           do ilist=1,ishield_list(j)
3138            iresshield=shield_list(ilist,j)
3139            do k=1,3
3140            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3141      &                                       /fac_shield(j)
3142 C     &     *2.0
3143            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3144      &              rlocshield
3145      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3146            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3147      &             +rlocshield
3148
3149            enddo
3150           enddo
3151
3152           do k=1,3
3153             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3154      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3155             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3156      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3157             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3158      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3159             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3160      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3161            enddo
3162            endif
3163
3164
3165 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3166 c     &                     ' eel_loc_ij',eel_loc_ij
3167 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3168 C Calculate patrial derivative for theta angle
3169 #ifdef NEWCORR
3170          geel_loc_ij=(a22*gmuij1(1)
3171      &     +a23*gmuij1(2)
3172      &     +a32*gmuij1(3)
3173      &     +a33*gmuij1(4))
3174      &    *fac_shield(i)*fac_shield(j)*sss
3175 c         write(iout,*) "derivative over thatai"
3176 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3177 c     &   a33*gmuij1(4)
3178          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3179      &      geel_loc_ij*wel_loc
3180 c         write(iout,*) "derivative over thatai-1"
3181 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3182 c     &   a33*gmuij2(4)
3183          geel_loc_ij=
3184      &     a22*gmuij2(1)
3185      &     +a23*gmuij2(2)
3186      &     +a32*gmuij2(3)
3187      &     +a33*gmuij2(4)
3188          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3189      &      geel_loc_ij*wel_loc
3190      &    *fac_shield(i)*fac_shield(j)*sss
3191
3192 c  Derivative over j residue
3193          geel_loc_ji=a22*gmuji1(1)
3194      &     +a23*gmuji1(2)
3195      &     +a32*gmuji1(3)
3196      &     +a33*gmuji1(4)
3197 c         write(iout,*) "derivative over thataj"
3198 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3199 c     &   a33*gmuji1(4)
3200
3201         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3202      &      geel_loc_ji*wel_loc
3203      &    *fac_shield(i)*fac_shield(j)
3204
3205          geel_loc_ji=
3206      &     +a22*gmuji2(1)
3207      &     +a23*gmuji2(2)
3208      &     +a32*gmuji2(3)
3209      &     +a33*gmuji2(4)
3210 c         write(iout,*) "derivative over thataj-1"
3211 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3212 c     &   a33*gmuji2(4)
3213          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3214      &      geel_loc_ji*wel_loc
3215      &    *fac_shield(i)*fac_shield(j)*sss
3216 #endif
3217 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3218
3219 C Partial derivatives in virtual-bond dihedral angles gamma
3220           if (i.gt.1)
3221      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3222      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3223      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3224      &    *fac_shield(i)*fac_shield(j)
3225
3226           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3227      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3228      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3229      &    *fac_shield(i)*fac_shield(j)
3230 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3231           aux=eel_loc_ij/sss*sssgrad*rmij
3232           ggg(1)=aux*xj
3233           ggg(2)=aux*yj
3234           ggg(3)=aux*zj
3235           do l=1,3
3236             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3237      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3238      &    *fac_shield(i)*fac_shield(j)*sss
3239             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3240             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3241 cgrad            ghalf=0.5d0*ggg(l)
3242 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3243 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3244           enddo
3245 cgrad          do k=i+1,j2
3246 cgrad            do l=1,3
3247 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3248 cgrad            enddo
3249 cgrad          enddo
3250 C Remaining derivatives of eello
3251           do l=1,3
3252             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3253      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3254      &    *fac_shield(i)*fac_shield(j)
3255
3256             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3257      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3258      &    *fac_shield(i)*fac_shield(j)
3259
3260             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3261      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3262      &    *fac_shield(i)*fac_shield(j)
3263
3264             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3265      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3266      &    *fac_shield(i)*fac_shield(j)
3267
3268           enddo
3269           endif ! calc_grad
3270           ENDIF
3271
3272
3273 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3274 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3275 #ifdef FOURBODY
3276           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3277      &       .and. num_conti.le.maxconts) then
3278 c            write (iout,*) i,j," entered corr"
3279 C
3280 C Calculate the contact function. The ith column of the array JCONT will
3281 C contain the numbers of atoms that make contacts with the atom I (of numbers
3282 C greater than I). The arrays FACONT and GACONT will contain the values of
3283 C the contact function and its derivative.
3284 c           r0ij=1.02D0*rpp(iteli,itelj)
3285 c           r0ij=1.11D0*rpp(iteli,itelj)
3286             r0ij=2.20D0*rpp(iteli,itelj)
3287 c           r0ij=1.55D0*rpp(iteli,itelj)
3288             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3289             if (fcont.gt.0.0D0) then
3290               num_conti=num_conti+1
3291               if (num_conti.gt.maxconts) then
3292                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3293      &                         ' will skip next contacts for this conf.'
3294               else
3295                 jcont_hb(num_conti,i)=j
3296 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3297 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3298                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3299      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3300 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3301 C  terms.
3302                 d_cont(num_conti,i)=rij
3303 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3304 C     --- Electrostatic-interaction matrix ---
3305                 a_chuj(1,1,num_conti,i)=a22
3306                 a_chuj(1,2,num_conti,i)=a23
3307                 a_chuj(2,1,num_conti,i)=a32
3308                 a_chuj(2,2,num_conti,i)=a33
3309 C     --- Gradient of rij
3310                 if (calc_grad) then
3311                 do kkk=1,3
3312                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3313                 enddo
3314                 kkll=0
3315                 do k=1,2
3316                   do l=1,2
3317                     kkll=kkll+1
3318                     do m=1,3
3319                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3320                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3321                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3322                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3323                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3324                     enddo
3325                   enddo
3326                 enddo
3327                 endif ! calc_grad
3328                 ENDIF
3329                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3330 C Calculate contact energies
3331                 cosa4=4.0D0*cosa
3332                 wij=cosa-3.0D0*cosb*cosg
3333                 cosbg1=cosb+cosg
3334                 cosbg2=cosb-cosg
3335 c               fac3=dsqrt(-ael6i)/r0ij**3
3336                 fac3=dsqrt(-ael6i)*r3ij
3337 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3338                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3339                 if (ees0tmp.gt.0) then
3340                   ees0pij=dsqrt(ees0tmp)
3341                 else
3342                   ees0pij=0
3343                 endif
3344 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3345                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3346                 if (ees0tmp.gt.0) then
3347                   ees0mij=dsqrt(ees0tmp)
3348                 else
3349                   ees0mij=0
3350                 endif
3351 c               ees0mij=0.0D0
3352                 if (shield_mode.eq.0) then
3353                 fac_shield(i)=1.0d0
3354                 fac_shield(j)=1.0d0
3355                 else
3356                 ees0plist(num_conti,i)=j
3357 C                fac_shield(i)=0.4d0
3358 C                fac_shield(j)=0.6d0
3359                 endif
3360                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3361      &          *fac_shield(i)*fac_shield(j)
3362                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3363      &          *fac_shield(i)*fac_shield(j)
3364 C Diagnostics. Comment out or remove after debugging!
3365 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3366 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3367 c               ees0m(num_conti,i)=0.0D0
3368 C End diagnostics.
3369 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3370 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3371 C Angular derivatives of the contact function
3372
3373                 ees0pij1=fac3/ees0pij
3374                 ees0mij1=fac3/ees0mij
3375                 fac3p=-3.0D0*fac3*rrmij
3376                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3377                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3378 c               ees0mij1=0.0D0
3379                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3380                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3381                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3382                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3383                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3384                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3385                 ecosap=ecosa1+ecosa2
3386                 ecosbp=ecosb1+ecosb2
3387                 ecosgp=ecosg1+ecosg2
3388                 ecosam=ecosa1-ecosa2
3389                 ecosbm=ecosb1-ecosb2
3390                 ecosgm=ecosg1-ecosg2
3391 C Diagnostics
3392 c               ecosap=ecosa1
3393 c               ecosbp=ecosb1
3394 c               ecosgp=ecosg1
3395 c               ecosam=0.0D0
3396 c               ecosbm=0.0D0
3397 c               ecosgm=0.0D0
3398 C End diagnostics
3399                 facont_hb(num_conti,i)=fcont
3400
3401                 if (calc_grad) then
3402                 fprimcont=fprimcont/rij
3403 cd              facont_hb(num_conti,i)=1.0D0
3404 C Following line is for diagnostics.
3405 cd              fprimcont=0.0D0
3406                 do k=1,3
3407                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3408                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3409                 enddo
3410                 do k=1,3
3411                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3412                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3413                 enddo
3414                 gggp(1)=gggp(1)+ees0pijp*xj
3415      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3416                 gggp(2)=gggp(2)+ees0pijp*yj
3417      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3418                 gggp(3)=gggp(3)+ees0pijp*zj
3419      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3420                 gggm(1)=gggm(1)+ees0mijp*xj
3421      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3422                 gggm(2)=gggm(2)+ees0mijp*yj
3423      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3424                 gggm(3)=gggm(3)+ees0mijp*zj
3425      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3426 C Derivatives due to the contact function
3427                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3428                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3429                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3430                 do k=1,3
3431 c
3432 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3433 c          following the change of gradient-summation algorithm.
3434 c
3435 cgrad                  ghalfp=0.5D0*gggp(k)
3436 cgrad                  ghalfm=0.5D0*gggm(k)
3437                   gacontp_hb1(k,num_conti,i)=!ghalfp
3438      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3439      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3440      &          *fac_shield(i)*fac_shield(j)*sss
3441
3442                   gacontp_hb2(k,num_conti,i)=!ghalfp
3443      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3444      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3445      &          *fac_shield(i)*fac_shield(j)*sss
3446
3447                   gacontp_hb3(k,num_conti,i)=gggp(k)
3448      &          *fac_shield(i)*fac_shield(j)*sss
3449
3450                   gacontm_hb1(k,num_conti,i)=!ghalfm
3451      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3452      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3453      &          *fac_shield(i)*fac_shield(j)*sss
3454
3455                   gacontm_hb2(k,num_conti,i)=!ghalfm
3456      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3457      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3458      &          *fac_shield(i)*fac_shield(j)*sss
3459
3460                   gacontm_hb3(k,num_conti,i)=gggm(k)
3461      &          *fac_shield(i)*fac_shield(j)*sss
3462
3463                 enddo
3464 C Diagnostics. Comment out or remove after debugging!
3465 cdiag           do k=1,3
3466 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3467 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3468 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3469 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3470 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3471 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3472 cdiag           enddo
3473
3474                  endif ! calc_grad
3475
3476               ENDIF ! wcorr
3477               endif  ! num_conti.le.maxconts
3478             endif  ! fcont.gt.0
3479           endif    ! j.gt.i+1
3480 #endif
3481           if (calc_grad) then
3482           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3483             do k=1,4
3484               do l=1,3
3485                 ghalf=0.5d0*agg(l,k)
3486                 aggi(l,k)=aggi(l,k)+ghalf
3487                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3488                 aggj(l,k)=aggj(l,k)+ghalf
3489               enddo
3490             enddo
3491             if (j.eq.nres-1 .and. i.lt.j-2) then
3492               do k=1,4
3493                 do l=1,3
3494                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3495                 enddo
3496               enddo
3497             endif
3498           endif
3499           endif ! calc_grad
3500 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3501       return
3502       end
3503 C-----------------------------------------------------------------------------
3504       subroutine eturn3(i,eello_turn3)
3505 C Third- and fourth-order contributions from turns
3506       implicit real*8 (a-h,o-z)
3507       include 'DIMENSIONS'
3508       include 'DIMENSIONS.ZSCOPT'
3509       include 'COMMON.IOUNITS'
3510       include 'COMMON.GEO'
3511       include 'COMMON.VAR'
3512       include 'COMMON.LOCAL'
3513       include 'COMMON.CHAIN'
3514       include 'COMMON.DERIV'
3515       include 'COMMON.INTERACT'
3516       include 'COMMON.CONTACTS'
3517       include 'COMMON.TORSION'
3518       include 'COMMON.VECTORS'
3519       include 'COMMON.FFIELD'
3520       include 'COMMON.CONTROL'
3521       include 'COMMON.SHIELD'
3522       include 'COMMON.CORRMAT'
3523       dimension ggg(3)
3524       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3525      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3526      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3527      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3528      &  auxgmat2(2,2),auxgmatt2(2,2)
3529       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3530      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3531       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3532      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3533      &    num_conti,j1,j2
3534       j=i+2
3535 c      write (iout,*) "eturn3",i,j,j1,j2
3536       a_temp(1,1)=a22
3537       a_temp(1,2)=a23
3538       a_temp(2,1)=a32
3539       a_temp(2,2)=a33
3540 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3541 C
3542 C               Third-order contributions
3543 C
3544 C                 (i+2)o----(i+3)
3545 C                      | |
3546 C                      | |
3547 C                 (i+1)o----i
3548 C
3549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3550 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3551         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3552 c auxalary matices for theta gradient
3553 c auxalary matrix for i+1 and constant i+2
3554         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3555 c auxalary matrix for i+2 and constant i+1
3556         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3557         call transpose2(auxmat(1,1),auxmat1(1,1))
3558         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3559         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3560         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3561         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3562         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3563         if (shield_mode.eq.0) then
3564         fac_shield(i)=1.0
3565         fac_shield(j)=1.0
3566 C        else
3567 C        fac_shield(i)=0.4
3568 C        fac_shield(j)=0.6
3569         endif
3570         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3571      &  *fac_shield(i)*fac_shield(j)
3572         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3573      &  *fac_shield(i)*fac_shield(j)
3574         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3575      &    eello_t3
3576         if (calc_grad) then
3577 C#ifdef NEWCORR
3578 C Derivatives in theta
3579         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3580      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3581      &   *fac_shield(i)*fac_shield(j)
3582         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3583      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3584      &   *fac_shield(i)*fac_shield(j)
3585 C#endif
3586
3587 C Derivatives in shield mode
3588           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3589      &  (shield_mode.gt.0)) then
3590 C          print *,i,j
3591
3592           do ilist=1,ishield_list(i)
3593            iresshield=shield_list(ilist,i)
3594            do k=1,3
3595            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3596 C     &      *2.0
3597            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3598      &              rlocshield
3599      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3600             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3601      &      +rlocshield
3602            enddo
3603           enddo
3604           do ilist=1,ishield_list(j)
3605            iresshield=shield_list(ilist,j)
3606            do k=1,3
3607            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3608 C     &     *2.0
3609            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3610      &              rlocshield
3611      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3612            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3613      &             +rlocshield
3614
3615            enddo
3616           enddo
3617
3618           do k=1,3
3619             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3620      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3621             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3622      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3623             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3624      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3625             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3626      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3627            enddo
3628            endif
3629
3630 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3631 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3632 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3633 cd     &    ' eello_turn3_num',4*eello_turn3_num
3634 C Derivatives in gamma(i)
3635         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3636         call transpose2(auxmat2(1,1),auxmat3(1,1))
3637         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3638         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3639      &   *fac_shield(i)*fac_shield(j)
3640 C Derivatives in gamma(i+1)
3641         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3642         call transpose2(auxmat2(1,1),auxmat3(1,1))
3643         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3644         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3645      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3646      &   *fac_shield(i)*fac_shield(j)
3647 C Cartesian derivatives
3648         do l=1,3
3649 c            ghalf1=0.5d0*agg(l,1)
3650 c            ghalf2=0.5d0*agg(l,2)
3651 c            ghalf3=0.5d0*agg(l,3)
3652 c            ghalf4=0.5d0*agg(l,4)
3653           a_temp(1,1)=aggi(l,1)!+ghalf1
3654           a_temp(1,2)=aggi(l,2)!+ghalf2
3655           a_temp(2,1)=aggi(l,3)!+ghalf3
3656           a_temp(2,2)=aggi(l,4)!+ghalf4
3657           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3658           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3659      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3660      &   *fac_shield(i)*fac_shield(j)
3661
3662           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3663           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3664           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3665           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3666           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3667           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3668      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3669      &   *fac_shield(i)*fac_shield(j)
3670           a_temp(1,1)=aggj(l,1)!+ghalf1
3671           a_temp(1,2)=aggj(l,2)!+ghalf2
3672           a_temp(2,1)=aggj(l,3)!+ghalf3
3673           a_temp(2,2)=aggj(l,4)!+ghalf4
3674           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3675           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3676      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3677      &   *fac_shield(i)*fac_shield(j)
3678           a_temp(1,1)=aggj1(l,1)
3679           a_temp(1,2)=aggj1(l,2)
3680           a_temp(2,1)=aggj1(l,3)
3681           a_temp(2,2)=aggj1(l,4)
3682           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3683           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3684      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3685      &   *fac_shield(i)*fac_shield(j)
3686         enddo
3687
3688         endif ! calc_grad
3689
3690       return
3691       end
3692 C-------------------------------------------------------------------------------
3693       subroutine eturn4(i,eello_turn4)
3694 C Third- and fourth-order contributions from turns
3695       implicit real*8 (a-h,o-z)
3696       include 'DIMENSIONS'
3697       include 'DIMENSIONS.ZSCOPT'
3698       include 'COMMON.IOUNITS'
3699       include 'COMMON.GEO'
3700       include 'COMMON.VAR'
3701       include 'COMMON.LOCAL'
3702       include 'COMMON.CHAIN'
3703       include 'COMMON.DERIV'
3704       include 'COMMON.INTERACT'
3705       include 'COMMON.CONTACTS'
3706       include 'COMMON.TORSION'
3707       include 'COMMON.VECTORS'
3708       include 'COMMON.FFIELD'
3709       include 'COMMON.CONTROL'
3710       include 'COMMON.SHIELD'
3711       include 'COMMON.CORRMAT'
3712       dimension ggg(3)
3713       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3714      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3715      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3716      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3717      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3718      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3719      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3720       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3721      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3722       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3723      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3724      &    num_conti,j1,j2
3725       j=i+3
3726 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3727 C
3728 C               Fourth-order contributions
3729 C
3730 C                 (i+3)o----(i+4)
3731 C                     /  |
3732 C               (i+2)o   |
3733 C                     \  |
3734 C                 (i+1)o----i
3735 C
3736 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3737 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3738 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3739 c        write(iout,*)"WCHODZE W PROGRAM"
3740         a_temp(1,1)=a22
3741         a_temp(1,2)=a23
3742         a_temp(2,1)=a32
3743         a_temp(2,2)=a33
3744         iti1=itype2loc(itype(i+1))
3745         iti2=itype2loc(itype(i+2))
3746         iti3=itype2loc(itype(i+3))
3747 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3748         call transpose2(EUg(1,1,i+1),e1t(1,1))
3749         call transpose2(Eug(1,1,i+2),e2t(1,1))
3750         call transpose2(Eug(1,1,i+3),e3t(1,1))
3751 C Ematrix derivative in theta
3752         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3753         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3754         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3755         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3756 c       eta1 in derivative theta
3757         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3758         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3759 c       auxgvec is derivative of Ub2 so i+3 theta
3760         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3761 c       auxalary matrix of E i+1
3762         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3763 c        s1=0.0
3764 c        gs1=0.0
3765         s1=scalar2(b1(1,i+2),auxvec(1))
3766 c derivative of theta i+2 with constant i+3
3767         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3768 c derivative of theta i+2 with constant i+2
3769         gs32=scalar2(b1(1,i+2),auxgvec(1))
3770 c derivative of E matix in theta of i+1
3771         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3772
3773         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3774 c       ea31 in derivative theta
3775         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3776         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3777 c auxilary matrix auxgvec of Ub2 with constant E matirx
3778         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3779 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3780         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3781
3782 c        s2=0.0
3783 c        gs2=0.0
3784         s2=scalar2(b1(1,i+1),auxvec(1))
3785 c derivative of theta i+1 with constant i+3
3786         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3787 c derivative of theta i+2 with constant i+1
3788         gs21=scalar2(b1(1,i+1),auxgvec(1))
3789 c derivative of theta i+3 with constant i+1
3790         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3791 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3792 c     &  gtb1(1,i+1)
3793         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3794 c two derivatives over diffetent matrices
3795 c gtae3e2 is derivative over i+3
3796         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3797 c ae3gte2 is derivative over i+2
3798         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3799         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3800 c three possible derivative over theta E matices
3801 c i+1
3802         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3803 c i+2
3804         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3805 c i+3
3806         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3807         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3808
3809         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3810         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3811         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3812         if (shield_mode.eq.0) then
3813         fac_shield(i)=1.0
3814         fac_shield(j)=1.0
3815 C        else
3816 C        fac_shield(i)=0.6
3817 C        fac_shield(j)=0.4
3818         endif
3819         eello_turn4=eello_turn4-(s1+s2+s3)
3820      &  *fac_shield(i)*fac_shield(j)
3821         eello_t4=-(s1+s2+s3)
3822      &  *fac_shield(i)*fac_shield(j)
3823 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3824         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3825      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3826 C Now derivative over shield:
3827           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3828      &  (shield_mode.gt.0)) then
3829 C          print *,i,j
3830
3831           do ilist=1,ishield_list(i)
3832            iresshield=shield_list(ilist,i)
3833            do k=1,3
3834            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3835 C     &      *2.0
3836            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3837      &              rlocshield
3838      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3839             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3840      &      +rlocshield
3841            enddo
3842           enddo
3843           do ilist=1,ishield_list(j)
3844            iresshield=shield_list(ilist,j)
3845            do k=1,3
3846            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3847 C     &     *2.0
3848            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3849      &              rlocshield
3850      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3851            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3852      &             +rlocshield
3853
3854            enddo
3855           enddo
3856
3857           do k=1,3
3858             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3859      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3860             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3861      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3862             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3863      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3864             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3865      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3866            enddo
3867            endif
3868 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3869 cd     &    ' eello_turn4_num',8*eello_turn4_num
3870 #ifdef NEWCORR
3871         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3872      &                  -(gs13+gsE13+gsEE1)*wturn4
3873      &  *fac_shield(i)*fac_shield(j)
3874         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3875      &                    -(gs23+gs21+gsEE2)*wturn4
3876      &  *fac_shield(i)*fac_shield(j)
3877
3878         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3879      &                    -(gs32+gsE31+gsEE3)*wturn4
3880      &  *fac_shield(i)*fac_shield(j)
3881
3882 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3883 c     &   gs2
3884 #endif
3885         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3886      &      'eturn4',i,j,-(s1+s2+s3)
3887 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3888 c     &    ' eello_turn4_num',8*eello_turn4_num
3889 C Derivatives in gamma(i)
3890         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3891         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3892         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3893         s1=scalar2(b1(1,i+2),auxvec(1))
3894         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3895         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3896         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3897      &  *fac_shield(i)*fac_shield(j)
3898 C Derivatives in gamma(i+1)
3899         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3900         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3901         s2=scalar2(b1(1,i+1),auxvec(1))
3902         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3903         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3904         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3905         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3906      &  *fac_shield(i)*fac_shield(j)
3907 C Derivatives in gamma(i+2)
3908         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3909         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3910         s1=scalar2(b1(1,i+2),auxvec(1))
3911         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3912         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3913         s2=scalar2(b1(1,i+1),auxvec(1))
3914         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3915         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3916         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3917         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3918      &  *fac_shield(i)*fac_shield(j)
3919         if (calc_grad) then
3920 C Cartesian derivatives
3921 C Derivatives of this turn contributions in DC(i+2)
3922         if (j.lt.nres-1) then
3923           do l=1,3
3924             a_temp(1,1)=agg(l,1)
3925             a_temp(1,2)=agg(l,2)
3926             a_temp(2,1)=agg(l,3)
3927             a_temp(2,2)=agg(l,4)
3928             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3929             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3930             s1=scalar2(b1(1,i+2),auxvec(1))
3931             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3932             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3933             s2=scalar2(b1(1,i+1),auxvec(1))
3934             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3935             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3936             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937             ggg(l)=-(s1+s2+s3)
3938             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3939      &  *fac_shield(i)*fac_shield(j)
3940           enddo
3941         endif
3942 C Remaining derivatives of this turn contribution
3943         do l=1,3
3944           a_temp(1,1)=aggi(l,1)
3945           a_temp(1,2)=aggi(l,2)
3946           a_temp(2,1)=aggi(l,3)
3947           a_temp(2,2)=aggi(l,4)
3948           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3949           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3950           s1=scalar2(b1(1,i+2),auxvec(1))
3951           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3952           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3953           s2=scalar2(b1(1,i+1),auxvec(1))
3954           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3955           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3956           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3957           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3958      &  *fac_shield(i)*fac_shield(j)
3959           a_temp(1,1)=aggi1(l,1)
3960           a_temp(1,2)=aggi1(l,2)
3961           a_temp(2,1)=aggi1(l,3)
3962           a_temp(2,2)=aggi1(l,4)
3963           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3964           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3965           s1=scalar2(b1(1,i+2),auxvec(1))
3966           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3967           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3968           s2=scalar2(b1(1,i+1),auxvec(1))
3969           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3970           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3971           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3973      &  *fac_shield(i)*fac_shield(j)
3974           a_temp(1,1)=aggj(l,1)
3975           a_temp(1,2)=aggj(l,2)
3976           a_temp(2,1)=aggj(l,3)
3977           a_temp(2,2)=aggj(l,4)
3978           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3979           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3980           s1=scalar2(b1(1,i+2),auxvec(1))
3981           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3982           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3983           s2=scalar2(b1(1,i+1),auxvec(1))
3984           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3985           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3986           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3988      &  *fac_shield(i)*fac_shield(j)
3989           a_temp(1,1)=aggj1(l,1)
3990           a_temp(1,2)=aggj1(l,2)
3991           a_temp(2,1)=aggj1(l,3)
3992           a_temp(2,2)=aggj1(l,4)
3993           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3994           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3995           s1=scalar2(b1(1,i+2),auxvec(1))
3996           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3997           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3998           s2=scalar2(b1(1,i+1),auxvec(1))
3999           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4000           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4001           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4002 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4003           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4004      &  *fac_shield(i)*fac_shield(j)
4005         enddo
4006
4007         endif ! calc_grad
4008
4009       return
4010       end
4011 C-----------------------------------------------------------------------------
4012       subroutine vecpr(u,v,w)
4013       implicit real*8(a-h,o-z)
4014       dimension u(3),v(3),w(3)
4015       w(1)=u(2)*v(3)-u(3)*v(2)
4016       w(2)=-u(1)*v(3)+u(3)*v(1)
4017       w(3)=u(1)*v(2)-u(2)*v(1)
4018       return
4019       end
4020 C-----------------------------------------------------------------------------
4021       subroutine unormderiv(u,ugrad,unorm,ungrad)
4022 C This subroutine computes the derivatives of a normalized vector u, given
4023 C the derivatives computed without normalization conditions, ugrad. Returns
4024 C ungrad.
4025       implicit none
4026       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4027       double precision vec(3)
4028       double precision scalar
4029       integer i,j
4030 c      write (2,*) 'ugrad',ugrad
4031 c      write (2,*) 'u',u
4032       do i=1,3
4033         vec(i)=scalar(ugrad(1,i),u(1))
4034       enddo
4035 c      write (2,*) 'vec',vec
4036       do i=1,3
4037         do j=1,3
4038           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4039         enddo
4040       enddo
4041 c      write (2,*) 'ungrad',ungrad
4042       return
4043       end
4044 C-----------------------------------------------------------------------------
4045       subroutine escp(evdw2,evdw2_14)
4046 C
4047 C This subroutine calculates the excluded-volume interaction energy between
4048 C peptide-group centers and side chains and its gradient in virtual-bond and
4049 C side-chain vectors.
4050 C
4051       implicit real*8 (a-h,o-z)
4052       include 'DIMENSIONS'
4053       include 'DIMENSIONS.ZSCOPT'
4054       include 'COMMON.CONTROL'
4055       include 'COMMON.GEO'
4056       include 'COMMON.VAR'
4057       include 'COMMON.LOCAL'
4058       include 'COMMON.CHAIN'
4059       include 'COMMON.DERIV'
4060       include 'COMMON.INTERACT'
4061       include 'COMMON.FFIELD'
4062       include 'COMMON.IOUNITS'
4063       dimension ggg(3)
4064       evdw2=0.0D0
4065       evdw2_14=0.0d0
4066 cd    print '(a)','Enter ESCP'
4067 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4068 c     &  ' scal14',scal14
4069       do i=iatscp_s,iatscp_e
4070         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4071         iteli=itel(i)
4072 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4073 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4074         if (iteli.eq.0) goto 1225
4075         xi=0.5D0*(c(1,i)+c(1,i+1))
4076         yi=0.5D0*(c(2,i)+c(2,i+1))
4077         zi=0.5D0*(c(3,i)+c(3,i+1))
4078 C Returning the ith atom to box
4079           xi=mod(xi,boxxsize)
4080           if (xi.lt.0) xi=xi+boxxsize
4081           yi=mod(yi,boxysize)
4082           if (yi.lt.0) yi=yi+boxysize
4083           zi=mod(zi,boxzsize)
4084           if (zi.lt.0) zi=zi+boxzsize
4085         do iint=1,nscp_gr(i)
4086
4087         do j=iscpstart(i,iint),iscpend(i,iint)
4088           itypj=iabs(itype(j))
4089           if (itypj.eq.ntyp1) cycle
4090 C Uncomment following three lines for SC-p interactions
4091 c         xj=c(1,nres+j)-xi
4092 c         yj=c(2,nres+j)-yi
4093 c         zj=c(3,nres+j)-zi
4094 C Uncomment following three lines for Ca-p interactions
4095           xj=c(1,j)
4096           yj=c(2,j)
4097           zj=c(3,j)
4098 C returning the jth atom to box
4099           xj=mod(xj,boxxsize)
4100           if (xj.lt.0) xj=xj+boxxsize
4101           yj=mod(yj,boxysize)
4102           if (yj.lt.0) yj=yj+boxysize
4103           zj=mod(zj,boxzsize)
4104           if (zj.lt.0) zj=zj+boxzsize
4105       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4106       xj_safe=xj
4107       yj_safe=yj
4108       zj_safe=zj
4109       subchap=0
4110 C Finding the closest jth atom
4111       do xshift=-1,1
4112       do yshift=-1,1
4113       do zshift=-1,1
4114           xj=xj_safe+xshift*boxxsize
4115           yj=yj_safe+yshift*boxysize
4116           zj=zj_safe+zshift*boxzsize
4117           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4118           if(dist_temp.lt.dist_init) then
4119             dist_init=dist_temp
4120             xj_temp=xj
4121             yj_temp=yj
4122             zj_temp=zj
4123             subchap=1
4124           endif
4125        enddo
4126        enddo
4127        enddo
4128        if (subchap.eq.1) then
4129           xj=xj_temp-xi
4130           yj=yj_temp-yi
4131           zj=zj_temp-zi
4132        else
4133           xj=xj_safe-xi
4134           yj=yj_safe-yi
4135           zj=zj_safe-zi
4136        endif
4137           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4138 C sss is scaling function for smoothing the cutoff gradient otherwise
4139 C the gradient would not be continuouse
4140           sss=sscale(1.0d0/(dsqrt(rrij)))
4141           if (sss.le.0.0d0) cycle
4142           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4143           fac=rrij**expon2
4144           e1=fac*fac*aad(itypj,iteli)
4145           e2=fac*bad(itypj,iteli)
4146           if (iabs(j-i) .le. 2) then
4147             e1=scal14*e1
4148             e2=scal14*e2
4149             evdw2_14=evdw2_14+(e1+e2)*sss
4150           endif
4151           evdwij=e1+e2
4152 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4153 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4154 c     &       bad(itypj,iteli)
4155           evdw2=evdw2+evdwij*sss
4156           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4157      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4158      &       bad(itypj,iteli)
4159
4160           if (calc_grad) then
4161 C
4162 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4163 C
4164           fac=-(evdwij+e1)*rrij*sss
4165           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4166           ggg(1)=xj*fac
4167           ggg(2)=yj*fac
4168           ggg(3)=zj*fac
4169           if (j.lt.i) then
4170 cd          write (iout,*) 'j<i'
4171 C Uncomment following three lines for SC-p interactions
4172 c           do k=1,3
4173 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4174 c           enddo
4175           else
4176 cd          write (iout,*) 'j>i'
4177             do k=1,3
4178               ggg(k)=-ggg(k)
4179 C Uncomment following line for SC-p interactions
4180 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4181             enddo
4182           endif
4183           do k=1,3
4184             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4185           enddo
4186           kstart=min0(i+1,j)
4187           kend=max0(i-1,j-1)
4188 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4189 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4190           do k=kstart,kend
4191             do l=1,3
4192               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4193             enddo
4194           enddo
4195           endif ! calc_grad
4196         enddo
4197         enddo ! iint
4198  1225   continue
4199       enddo ! i
4200       do i=1,nct
4201         do j=1,3
4202           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4203           gradx_scp(j,i)=expon*gradx_scp(j,i)
4204         enddo
4205       enddo
4206 C******************************************************************************
4207 C
4208 C                              N O T E !!!
4209 C
4210 C To save time the factor EXPON has been extracted from ALL components
4211 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4212 C use!
4213 C
4214 C******************************************************************************
4215       return
4216       end
4217 C--------------------------------------------------------------------------
4218       subroutine edis(ehpb)
4219 C
4220 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4221 C
4222       implicit real*8 (a-h,o-z)
4223       include 'DIMENSIONS'
4224       include 'DIMENSIONS.ZSCOPT'
4225       include 'COMMON.SBRIDGE'
4226       include 'COMMON.CHAIN'
4227       include 'COMMON.DERIV'
4228       include 'COMMON.VAR'
4229       include 'COMMON.INTERACT'
4230       include 'COMMON.CONTROL'
4231       include 'COMMON.IOUNITS'
4232       dimension ggg(3),ggg_peak(3,1000)
4233       ehpb=0.0D0
4234       do i=1,3
4235        ggg(i)=0.0d0
4236       enddo
4237 c 8/21/18 AL: added explicit restraints on reference coords
4238 c      write (iout,*) "restr_on_coord",restr_on_coord
4239       if (restr_on_coord) then
4240
4241       do i=nnt,nct
4242         ecoor=0.0d0
4243         if (itype(i).eq.ntyp1) cycle
4244         do j=1,3
4245           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4246           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4247         enddo
4248         if (itype(i).ne.10) then
4249           do j=1,3
4250             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4251             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4252           enddo
4253         endif
4254         if (energy_dec) write (iout,*)
4255      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4256         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4257       enddo
4258
4259       endif
4260
4261 C      write (iout,*) ,"link_end",link_end,constr_dist
4262 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4263 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4264 c     &  " constr_dist",constr_dist
4265       if (link_end.eq.0.and.link_end_peak.eq.0) return
4266       do i=link_start_peak,link_end_peak
4267         ehpb_peak=0.0d0
4268 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4269 c     &   ipeak(1,i),ipeak(2,i)
4270         do ip=ipeak(1,i),ipeak(2,i)
4271           ii=ihpb_peak(ip)
4272           jj=jhpb_peak(ip)
4273           dd=dist(ii,jj)
4274           iip=ip-ipeak(1,i)+1
4275 C iii and jjj point to the residues for which the distance is assigned.
4276 c          if (ii.gt.nres) then
4277 c            iii=ii-nres
4278 c            jjj=jj-nres
4279 c          else
4280 c            iii=ii
4281 c            jjj=jj
4282 c          endif
4283           if (ii.gt.nres) then
4284             iii=ii-nres
4285           else
4286             iii=ii
4287           endif
4288           if (jj.gt.nres) then
4289             jjj=jj-nres
4290           else
4291             jjj=jj
4292           endif
4293           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4294           aux=dexp(-scal_peak*aux)
4295           ehpb_peak=ehpb_peak+aux
4296           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4297      &      forcon_peak(ip))*aux/dd
4298           do j=1,3
4299             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4300           enddo
4301           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4302      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4303      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4304         enddo
4305 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4306         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4307         do ip=ipeak(1,i),ipeak(2,i)
4308           iip=ip-ipeak(1,i)+1
4309           do j=1,3
4310             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4311           enddo
4312           ii=ihpb_peak(ip)
4313           jj=jhpb_peak(ip)
4314 C iii and jjj point to the residues for which the distance is assigned.
4315           if (ii.gt.nres) then
4316             iii=ii-nres
4317             jjj=jj-nres
4318           else
4319             iii=ii
4320             jjj=jj
4321           endif
4322           if (iii.lt.ii) then
4323             do j=1,3
4324               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4325             enddo
4326           endif
4327           if (jjj.lt.jj) then
4328             do j=1,3
4329               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4330             enddo
4331           endif
4332           do k=1,3
4333             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4334             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4335           enddo
4336         enddo
4337       enddo
4338       do i=link_start,link_end
4339 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4340 C CA-CA distance used in regularization of structure.
4341         ii=ihpb(i)
4342         jj=jhpb(i)
4343 C iii and jjj point to the residues for which the distance is assigned.
4344         if (ii.gt.nres) then
4345           iii=ii-nres
4346         else
4347           iii=ii
4348         endif
4349         if (jj.gt.nres) then
4350           jjj=jj-nres
4351         else
4352           jjj=jj
4353         endif
4354 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4355 c     &    dhpb(i),dhpb1(i),forcon(i)
4356 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4357 C    distance and angle dependent SS bond potential.
4358 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4359 C     & iabs(itype(jjj)).eq.1) then
4360 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4361 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4362         if (.not.dyn_ss .and. i.le.nss) then
4363 C 15/02/13 CC dynamic SSbond - additional check
4364           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4365      &        iabs(itype(jjj)).eq.1) then
4366            call ssbond_ene(iii,jjj,eij)
4367            ehpb=ehpb+2*eij
4368          endif
4369 cd          write (iout,*) "eij",eij
4370 cd   &   ' waga=',waga,' fac=',fac
4371 !        else if (ii.gt.nres .and. jj.gt.nres) then
4372         else
4373 C Calculate the distance between the two points and its difference from the
4374 C target distance.
4375           dd=dist(ii,jj)
4376           if (irestr_type(i).eq.11) then
4377             ehpb=ehpb+fordepth(i)!**4.0d0
4378      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4379             fac=fordepth(i)!**4.0d0
4380      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4381             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4382      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4383      &        ehpb,irestr_type(i)
4384           else if (irestr_type(i).eq.10) then
4385 c AL 6//19/2018 cross-link restraints
4386             xdis = 0.5d0*(dd/forcon(i))**2
4387             expdis = dexp(-xdis)
4388 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4389             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4390 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4391 c     &          " wboltzd",wboltzd
4392             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4393 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4394             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4395      &           *expdis/(aux*forcon(i)**2)
4396             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4397      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4398      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4399           else if (irestr_type(i).eq.2) then
4400 c Quartic restraints
4401             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4402             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4403      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4404      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4405             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4406           else
4407 c Quadratic restraints
4408             rdis=dd-dhpb(i)
4409 C Get the force constant corresponding to this distance.
4410             waga=forcon(i)
4411 C Calculate the contribution to energy.
4412             ehpb=ehpb+0.5d0*waga*rdis*rdis
4413             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4414      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4415      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4416 C
4417 C Evaluate gradient.
4418 C
4419             fac=waga*rdis/dd
4420           endif
4421 c Calculate Cartesian gradient
4422           do j=1,3
4423             ggg(j)=fac*(c(j,jj)-c(j,ii))
4424           enddo
4425 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4426 C If this is a SC-SC distance, we need to calculate the contributions to the
4427 C Cartesian gradient in the SC vectors (ghpbx).
4428           if (iii.lt.ii) then
4429             do j=1,3
4430               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4431             enddo
4432           endif
4433           if (jjj.lt.jj) then
4434             do j=1,3
4435               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4436             enddo
4437           endif
4438           do k=1,3
4439             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4440             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4441           enddo
4442         endif
4443       enddo
4444       return
4445       end
4446 C--------------------------------------------------------------------------
4447       subroutine ssbond_ene(i,j,eij)
4448 C
4449 C Calculate the distance and angle dependent SS-bond potential energy
4450 C using a free-energy function derived based on RHF/6-31G** ab initio
4451 C calculations of diethyl disulfide.
4452 C
4453 C A. Liwo and U. Kozlowska, 11/24/03
4454 C
4455       implicit real*8 (a-h,o-z)
4456       include 'DIMENSIONS'
4457       include 'DIMENSIONS.ZSCOPT'
4458       include 'COMMON.SBRIDGE'
4459       include 'COMMON.CHAIN'
4460       include 'COMMON.DERIV'
4461       include 'COMMON.LOCAL'
4462       include 'COMMON.INTERACT'
4463       include 'COMMON.VAR'
4464       include 'COMMON.IOUNITS'
4465       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4466       itypi=iabs(itype(i))
4467       xi=c(1,nres+i)
4468       yi=c(2,nres+i)
4469       zi=c(3,nres+i)
4470       dxi=dc_norm(1,nres+i)
4471       dyi=dc_norm(2,nres+i)
4472       dzi=dc_norm(3,nres+i)
4473       dsci_inv=dsc_inv(itypi)
4474       itypj=iabs(itype(j))
4475       dscj_inv=dsc_inv(itypj)
4476       xj=c(1,nres+j)-xi
4477       yj=c(2,nres+j)-yi
4478       zj=c(3,nres+j)-zi
4479       dxj=dc_norm(1,nres+j)
4480       dyj=dc_norm(2,nres+j)
4481       dzj=dc_norm(3,nres+j)
4482       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4483       rij=dsqrt(rrij)
4484       erij(1)=xj*rij
4485       erij(2)=yj*rij
4486       erij(3)=zj*rij
4487       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4488       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4489       om12=dxi*dxj+dyi*dyj+dzi*dzj
4490       do k=1,3
4491         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4492         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4493       enddo
4494       rij=1.0d0/rij
4495       deltad=rij-d0cm
4496       deltat1=1.0d0-om1
4497       deltat2=1.0d0+om2
4498       deltat12=om2-om1+2.0d0
4499       cosphi=om12-om1*om2
4500       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4501      &  +akct*deltad*deltat12
4502      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4503 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4504 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4505 c     &  " deltat12",deltat12," eij",eij
4506       ed=2*akcm*deltad+akct*deltat12
4507       pom1=akct*deltad
4508       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4509       eom1=-2*akth*deltat1-pom1-om2*pom2
4510       eom2= 2*akth*deltat2+pom1-om1*pom2
4511       eom12=pom2
4512       do k=1,3
4513         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4514       enddo
4515       do k=1,3
4516         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4517      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4518         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4519      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4520       enddo
4521 C
4522 C Calculate the components of the gradient in DC and X
4523 C
4524       do k=i,j-1
4525         do l=1,3
4526           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4527         enddo
4528       enddo
4529       return
4530       end
4531 C--------------------------------------------------------------------------
4532 c MODELLER restraint function
4533       subroutine e_modeller(ehomology_constr)
4534       implicit real*8 (a-h,o-z)
4535       include 'DIMENSIONS'
4536       include 'DIMENSIONS.ZSCOPT'
4537       include 'DIMENSIONS.FREE'
4538       integer nnn, i, j, k, ki, irec, l
4539       integer katy, odleglosci, test7
4540       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4541       real*8 distance(max_template),distancek(max_template),
4542      &    min_odl,godl(max_template),dih_diff(max_template)
4543
4544 c
4545 c     FP - 30/10/2014 Temporary specifications for homology restraints
4546 c
4547       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4548      &                 sgtheta
4549       double precision, dimension (maxres) :: guscdiff,usc_diff
4550       double precision, dimension (max_template) ::
4551      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4552      &           theta_diff
4553
4554       include 'COMMON.SBRIDGE'
4555       include 'COMMON.CHAIN'
4556       include 'COMMON.GEO'
4557       include 'COMMON.DERIV'
4558       include 'COMMON.LOCAL'
4559       include 'COMMON.INTERACT'
4560       include 'COMMON.VAR'
4561       include 'COMMON.IOUNITS'
4562       include 'COMMON.CONTROL'
4563       include 'COMMON.HOMRESTR'
4564       include 'COMMON.HOMOLOGY'
4565       include 'COMMON.SETUP'
4566       include 'COMMON.NAMES'
4567
4568       do i=1,max_template
4569         distancek(i)=9999999.9
4570       enddo
4571
4572       odleg=0.0d0
4573
4574 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4575 c function)
4576 C AL 5/2/14 - Introduce list of restraints
4577 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4578 #ifdef DEBUG
4579       write(iout,*) "------- dist restrs start -------"
4580 #endif
4581       do ii = link_start_homo,link_end_homo
4582          i = ires_homo(ii)
4583          j = jres_homo(ii)
4584          dij=dist(i,j)
4585 c        write (iout,*) "dij(",i,j,") =",dij
4586          nexl=0
4587          do k=1,constr_homology
4588            if(.not.l_homo(k,ii)) then
4589               nexl=nexl+1
4590               cycle
4591            endif
4592            distance(k)=odl(k,ii)-dij
4593 c          write (iout,*) "distance(",k,") =",distance(k)
4594 c
4595 c          For Gaussian-type Urestr
4596 c
4597            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4598 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4599 c          write (iout,*) "distancek(",k,") =",distancek(k)
4600 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4601 c
4602 c          For Lorentzian-type Urestr
4603 c
4604            if (waga_dist.lt.0.0d0) then
4605               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4606               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4607      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4608            endif
4609          enddo
4610
4611 c         min_odl=minval(distancek)
4612          if (nexl.gt.0) then
4613            min_odl=0.0d0
4614          else
4615            do kk=1,constr_homology
4616             if(l_homo(kk,ii)) then
4617               min_odl=distancek(kk)
4618               exit
4619             endif
4620            enddo
4621            do kk=1,constr_homology
4622             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4623      &              min_odl=distancek(kk)
4624            enddo
4625          endif
4626 c        write (iout,* )"min_odl",min_odl
4627 #ifdef DEBUG
4628          write (iout,*) "ij dij",i,j,dij
4629          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4630          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4631          write (iout,* )"min_odl",min_odl
4632 #endif
4633 #ifdef OLDRESTR
4634          odleg2=0.0d0
4635 #else
4636          if (waga_dist.ge.0.0d0) then
4637            odleg2=nexl
4638          else
4639            odleg2=0.0d0
4640          endif
4641 #endif
4642          do k=1,constr_homology
4643 c Nie wiem po co to liczycie jeszcze raz!
4644 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4645 c     &              (2*(sigma_odl(i,j,k))**2))
4646            if(.not.l_homo(k,ii)) cycle
4647            if (waga_dist.ge.0.0d0) then
4648 c
4649 c          For Gaussian-type Urestr
4650 c
4651             godl(k)=dexp(-distancek(k)+min_odl)
4652             odleg2=odleg2+godl(k)
4653 c
4654 c          For Lorentzian-type Urestr
4655 c
4656            else
4657             odleg2=odleg2+distancek(k)
4658            endif
4659
4660 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4661 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4662 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4663 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4664
4665          enddo
4666 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4667 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4668 #ifdef DEBUG
4669          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4670          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4671 #endif
4672            if (waga_dist.ge.0.0d0) then
4673 c
4674 c          For Gaussian-type Urestr
4675 c
4676               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4677 c
4678 c          For Lorentzian-type Urestr
4679 c
4680            else
4681               odleg=odleg+odleg2/constr_homology
4682            endif
4683 c
4684 #ifdef GRAD
4685 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4686 c Gradient
4687 c
4688 c          For Gaussian-type Urestr
4689 c
4690          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4691          sum_sgodl=0.0d0
4692          do k=1,constr_homology
4693 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4694 c     &           *waga_dist)+min_odl
4695 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4696 c
4697          if(.not.l_homo(k,ii)) cycle
4698          if (waga_dist.ge.0.0d0) then
4699 c          For Gaussian-type Urestr
4700 c
4701            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4702 c
4703 c          For Lorentzian-type Urestr
4704 c
4705          else
4706            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4707      &           sigma_odlir(k,ii)**2)**2)
4708          endif
4709            sum_sgodl=sum_sgodl+sgodl
4710
4711 c            sgodl2=sgodl2+sgodl
4712 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4713 c      write(iout,*) "constr_homology=",constr_homology
4714 c      write(iout,*) i, j, k, "TEST K"
4715          enddo
4716          if (waga_dist.ge.0.0d0) then
4717 c
4718 c          For Gaussian-type Urestr
4719 c
4720             grad_odl3=waga_homology(iset)*waga_dist
4721      &                *sum_sgodl/(sum_godl*dij)
4722 c
4723 c          For Lorentzian-type Urestr
4724 c
4725          else
4726 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4727 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4728             grad_odl3=-waga_homology(iset)*waga_dist*
4729      &                sum_sgodl/(constr_homology*dij)
4730          endif
4731 c
4732 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4733
4734
4735 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4736 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4737 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4738
4739 ccc      write(iout,*) godl, sgodl, grad_odl3
4740
4741 c          grad_odl=grad_odl+grad_odl3
4742
4743          do jik=1,3
4744             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4745 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4746 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4747 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4748             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4749             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4750 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4751 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4752 c         if (i.eq.25.and.j.eq.27) then
4753 c         write(iout,*) "jik",jik,"i",i,"j",j
4754 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4755 c         write(iout,*) "grad_odl3",grad_odl3
4756 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4757 c         write(iout,*) "ggodl",ggodl
4758 c         write(iout,*) "ghpbc(",jik,i,")",
4759 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4760 c     &                 ghpbc(jik,j)
4761 c         endif
4762          enddo
4763 #endif
4764 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4765 ccc     & dLOG(odleg2),"-odleg=", -odleg
4766
4767       enddo ! ii-loop for dist
4768 #ifdef DEBUG
4769       write(iout,*) "------- dist restrs end -------"
4770 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4771 c    &     waga_d.eq.1.0d0) call sum_gradient
4772 #endif
4773 c Pseudo-energy and gradient from dihedral-angle restraints from
4774 c homology templates
4775 c      write (iout,*) "End of distance loop"
4776 c      call flush(iout)
4777       kat=0.0d0
4778 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4779 #ifdef DEBUG
4780       write(iout,*) "------- dih restrs start -------"
4781       do i=idihconstr_start_homo,idihconstr_end_homo
4782         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4783       enddo
4784 #endif
4785       do i=idihconstr_start_homo,idihconstr_end_homo
4786         kat2=0.0d0
4787 c        betai=beta(i,i+1,i+2,i+3)
4788         betai = phi(i)
4789 c       write (iout,*) "betai =",betai
4790         do k=1,constr_homology
4791           dih_diff(k)=pinorm(dih(k,i)-betai)
4792 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4793 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4794 c     &                                   -(6.28318-dih_diff(i,k))
4795 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4796 c     &                                   6.28318+dih_diff(i,k)
4797 #ifdef OLD_DIHED
4798           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4799 #else
4800           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4801 #endif
4802 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4803           gdih(k)=dexp(kat3)
4804           kat2=kat2+gdih(k)
4805 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4806 c          write(*,*)""
4807         enddo
4808 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4809 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4810 #ifdef DEBUG
4811         write (iout,*) "i",i," betai",betai," kat2",kat2
4812         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4813 #endif
4814         if (kat2.le.1.0d-14) cycle
4815         kat=kat-dLOG(kat2/constr_homology)
4816 c       write (iout,*) "kat",kat ! sum of -ln-s
4817
4818 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4819 ccc     & dLOG(kat2), "-kat=", -kat
4820
4821 #ifdef GRAD
4822 c ----------------------------------------------------------------------
4823 c Gradient
4824 c ----------------------------------------------------------------------
4825
4826         sum_gdih=kat2
4827         sum_sgdih=0.0d0
4828         do k=1,constr_homology
4829 #ifdef OLD_DIHED
4830           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4831 #else
4832           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4833 #endif
4834 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4835           sum_sgdih=sum_sgdih+sgdih
4836         enddo
4837 c       grad_dih3=sum_sgdih/sum_gdih
4838         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4839
4840 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4841 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4842 ccc     & gloc(nphi+i-3,icg)
4843         gloc(i,icg)=gloc(i,icg)+grad_dih3
4844 c        if (i.eq.25) then
4845 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4846 c        endif
4847 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4848 ccc     & gloc(nphi+i-3,icg)
4849 #endif
4850       enddo ! i-loop for dih
4851 #ifdef DEBUG
4852       write(iout,*) "------- dih restrs end -------"
4853 #endif
4854
4855 c Pseudo-energy and gradient for theta angle restraints from
4856 c homology templates
4857 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4858 c adapted
4859
4860 c
4861 c     For constr_homology reference structures (FP)
4862 c
4863 c     Uconst_back_tot=0.0d0
4864       Eval=0.0d0
4865       Erot=0.0d0
4866 c     Econstr_back legacy
4867 #ifdef GRAD
4868       do i=1,nres
4869 c     do i=ithet_start,ithet_end
4870        dutheta(i)=0.0d0
4871 c     enddo
4872 c     do i=loc_start,loc_end
4873         do j=1,3
4874           duscdiff(j,i)=0.0d0
4875           duscdiffx(j,i)=0.0d0
4876         enddo
4877       enddo
4878 #endif
4879 c
4880 c     do iref=1,nref
4881 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4882 c     write (iout,*) "waga_theta",waga_theta
4883       if (waga_theta.gt.0.0d0) then
4884 #ifdef DEBUG
4885       write (iout,*) "usampl",usampl
4886       write(iout,*) "------- theta restrs start -------"
4887 c     do i=ithet_start,ithet_end
4888 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4889 c     enddo
4890 #endif
4891 c     write (iout,*) "maxres",maxres,"nres",nres
4892
4893       do i=ithet_start,ithet_end
4894 c
4895 c     do i=1,nfrag_back
4896 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4897 c
4898 c Deviation of theta angles wrt constr_homology ref structures
4899 c
4900         utheta_i=0.0d0 ! argument of Gaussian for single k
4901         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4902 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4903 c       over residues in a fragment
4904 c       write (iout,*) "theta(",i,")=",theta(i)
4905         do k=1,constr_homology
4906 c
4907 c         dtheta_i=theta(j)-thetaref(j,iref)
4908 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4909           theta_diff(k)=thetatpl(k,i)-theta(i)
4910 c
4911           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4912 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4913           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4914           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4915 c         Gradient for single Gaussian restraint in subr Econstr_back
4916 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4917 c
4918         enddo
4919 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4920 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4921
4922 c
4923 #ifdef GRAD
4924 c         Gradient for multiple Gaussian restraint
4925         sum_gtheta=gutheta_i
4926         sum_sgtheta=0.0d0
4927         do k=1,constr_homology
4928 c        New generalized expr for multiple Gaussian from Econstr_back
4929          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4930 c
4931 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4932           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4933         enddo
4934 c
4935 c       Final value of gradient using same var as in Econstr_back
4936         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4937      &               *waga_homology(iset)
4938 c       dutheta(i)=sum_sgtheta/sum_gtheta
4939 c
4940 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4941 #endif
4942         Eval=Eval-dLOG(gutheta_i/constr_homology)
4943 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4944 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4945 c       Uconst_back=Uconst_back+utheta(i)
4946       enddo ! (i-loop for theta)
4947 #ifdef DEBUG
4948       write(iout,*) "------- theta restrs end -------"
4949 #endif
4950       endif
4951 c
4952 c Deviation of local SC geometry
4953 c
4954 c Separation of two i-loops (instructed by AL - 11/3/2014)
4955 c
4956 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4957 c     write (iout,*) "waga_d",waga_d
4958
4959 #ifdef DEBUG
4960       write(iout,*) "------- SC restrs start -------"
4961       write (iout,*) "Initial duscdiff,duscdiffx"
4962       do i=loc_start,loc_end
4963         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4964      &                 (duscdiffx(jik,i),jik=1,3)
4965       enddo
4966 #endif
4967       do i=loc_start,loc_end
4968         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4969         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4970 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4971 c       write(iout,*) "xxtab, yytab, zztab"
4972 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4973         do k=1,constr_homology
4974 c
4975           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4976 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4977           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4978           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4979 c         write(iout,*) "dxx, dyy, dzz"
4980 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4981 c
4982           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4983 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4984 c         uscdiffk(k)=usc_diff(i)
4985           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4986           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4987 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4988 c     &      xxref(j),yyref(j),zzref(j)
4989         enddo
4990 c
4991 c       Gradient
4992 c
4993 c       Generalized expression for multiple Gaussian acc to that for a single
4994 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4995 c
4996 c       Original implementation
4997 c       sum_guscdiff=guscdiff(i)
4998 c
4999 c       sum_sguscdiff=0.0d0
5000 c       do k=1,constr_homology
5001 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
5002 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
5003 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
5004 c       enddo
5005 c
5006 c       Implementation of new expressions for gradient (Jan. 2015)
5007 c
5008 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
5009 #ifdef GRAD
5010         do k=1,constr_homology
5011 c
5012 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
5013 c       before. Now the drivatives should be correct
5014 c
5015           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
5016 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
5017           dyy=-yytpl(k,i)+yytab(i) ! ibid y
5018           dzz=-zztpl(k,i)+zztab(i) ! ibid z
5019 c
5020 c         New implementation
5021 c
5022           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
5023      &                 sigma_d(k,i) ! for the grad wrt r'
5024 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
5025 c
5026 c
5027 c        New implementation
5028          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
5029          do jik=1,3
5030             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
5031      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
5032      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
5033             duscdiff(jik,i)=duscdiff(jik,i)+
5034      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
5035      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
5036             duscdiffx(jik,i)=duscdiffx(jik,i)+
5037      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
5038      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
5039 c
5040 #ifdef DEBUG
5041              write(iout,*) "jik",jik,"i",i
5042              write(iout,*) "dxx, dyy, dzz"
5043              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
5044              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
5045 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
5046 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
5047 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
5048 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
5049 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
5050 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
5051 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
5052 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
5053 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
5054 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
5055 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
5056 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
5057 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
5058 c            endif
5059 #endif
5060          enddo
5061         enddo
5062 #endif
5063 c
5064 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
5065 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
5066 c
5067 c        write (iout,*) i," uscdiff",uscdiff(i)
5068 c
5069 c Put together deviations from local geometry
5070
5071 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
5072 c      &            wfrag_back(3,i,iset)*uscdiff(i)
5073         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
5074 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
5075 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
5076 c       Uconst_back=Uconst_back+usc_diff(i)
5077 c
5078 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
5079 c
5080 c     New implment: multiplied by sum_sguscdiff
5081 c
5082
5083       enddo ! (i-loop for dscdiff)
5084
5085 c      endif
5086
5087 #ifdef DEBUG
5088       write(iout,*) "------- SC restrs end -------"
5089         write (iout,*) "------ After SC loop in e_modeller ------"
5090         do i=loc_start,loc_end
5091          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
5092          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
5093         enddo
5094       if (waga_theta.eq.1.0d0) then
5095       write (iout,*) "in e_modeller after SC restr end: dutheta"
5096       do i=ithet_start,ithet_end
5097         write (iout,*) i,dutheta(i)
5098       enddo
5099       endif
5100       if (waga_d.eq.1.0d0) then
5101       write (iout,*) "e_modeller after SC loop: duscdiff/x"
5102       do i=1,nres
5103         write (iout,*) i,(duscdiff(j,i),j=1,3)
5104         write (iout,*) i,(duscdiffx(j,i),j=1,3)
5105       enddo
5106       endif
5107 #endif
5108
5109 c Total energy from homology restraints
5110 #ifdef DEBUG
5111       write (iout,*) "odleg",odleg," kat",kat
5112       write (iout,*) "odleg",odleg," kat",kat
5113       write (iout,*) "Eval",Eval," Erot",Erot
5114       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5115       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5116       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5117 #endif
5118 c
5119 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5120 c
5121 c     ehomology_constr=odleg+kat
5122 c
5123 c     For Lorentzian-type Urestr
5124 c
5125
5126       if (waga_dist.ge.0.0d0) then
5127 c
5128 c          For Gaussian-type Urestr
5129 c
5130 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5131 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5132         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5133      &              waga_theta*Eval+waga_d*Erot
5134 c     write (iout,*) "ehomology_constr=",ehomology_constr
5135       else
5136 c
5137 c          For Lorentzian-type Urestr
5138 c
5139 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5140 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5141         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5142      &              waga_theta*Eval+waga_d*Erot
5143 c     write (iout,*) "ehomology_constr=",ehomology_constr
5144       endif
5145 #ifdef DEBUG
5146       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5147      & "Eval",waga_theta,eval,
5148      &   "Erot",waga_d,Erot
5149       write (iout,*) "ehomology_constr",ehomology_constr
5150 #endif
5151       return
5152
5153   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5154   747 format(a12,i4,i4,i4,f8.3,f8.3)
5155   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5156   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5157   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5158      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5159       end
5160 c-----------------------------------------------------------------------
5161       subroutine ebond(estr)
5162 c
5163 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5164 c
5165       implicit real*8 (a-h,o-z)
5166       include 'DIMENSIONS'
5167       include 'DIMENSIONS.ZSCOPT'
5168       include 'COMMON.LOCAL'
5169       include 'COMMON.GEO'
5170       include 'COMMON.INTERACT'
5171       include 'COMMON.DERIV'
5172       include 'COMMON.VAR'
5173       include 'COMMON.CHAIN'
5174       include 'COMMON.IOUNITS'
5175       include 'COMMON.NAMES'
5176       include 'COMMON.FFIELD'
5177       include 'COMMON.CONTROL'
5178       double precision u(3),ud(3)
5179       estr=0.0d0
5180       estr1=0.0d0
5181 c      write (iout,*) "distchainmax",distchainmax
5182       do i=nnt+1,nct
5183 #ifdef FIVEDIAG
5184         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5185         diff = vbld(i)-vbldp0
5186 #else
5187         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5188 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5189 C          do j=1,3
5190 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5191 C     &      *dc(j,i-1)/vbld(i)
5192 C          enddo
5193 C          if (energy_dec) write(iout,*)
5194 C     &       "estr1",i,vbld(i),distchainmax,
5195 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5196 C        else
5197          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5198         diff = vbld(i)-vbldpDUM
5199 C         write(iout,*) i,diff
5200          else
5201           diff = vbld(i)-vbldp0
5202 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5203          endif
5204 #endif
5205           estr=estr+diff*diff
5206           do j=1,3
5207             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5208           enddo
5209 C        endif
5210           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5211      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5212       enddo
5213       estr=0.5d0*AKP*estr+estr1
5214 c
5215 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5216 c
5217       do i=nnt,nct
5218         iti=iabs(itype(i))
5219         if (iti.ne.10 .and. iti.ne.ntyp1) then
5220           nbi=nbondterm(iti)
5221           if (nbi.eq.1) then
5222             diff=vbld(i+nres)-vbldsc0(1,iti)
5223             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5224      &      vbldsc0(1,iti),diff,
5225      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5226             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5227             do j=1,3
5228               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5229             enddo
5230           else
5231             do j=1,nbi
5232               diff=vbld(i+nres)-vbldsc0(j,iti)
5233               ud(j)=aksc(j,iti)*diff
5234               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5235             enddo
5236             uprod=u(1)
5237             do j=2,nbi
5238               uprod=uprod*u(j)
5239             enddo
5240             usum=0.0d0
5241             usumsqder=0.0d0
5242             do j=1,nbi
5243               uprod1=1.0d0
5244               uprod2=1.0d0
5245               do k=1,nbi
5246                 if (k.ne.j) then
5247                   uprod1=uprod1*u(k)
5248                   uprod2=uprod2*u(k)*u(k)
5249                 endif
5250               enddo
5251               usum=usum+uprod1
5252               usumsqder=usumsqder+ud(j)*uprod2
5253             enddo
5254 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5255 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5256             estr=estr+uprod/usum
5257             do j=1,3
5258              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5259             enddo
5260           endif
5261         endif
5262       enddo
5263       return
5264       end
5265 #ifdef CRYST_THETA
5266 C--------------------------------------------------------------------------
5267       subroutine ebend(etheta,ethetacnstr)
5268 C
5269 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5270 C angles gamma and its derivatives in consecutive thetas and gammas.
5271 C
5272       implicit real*8 (a-h,o-z)
5273       include 'DIMENSIONS'
5274       include 'DIMENSIONS.ZSCOPT'
5275       include 'COMMON.LOCAL'
5276       include 'COMMON.GEO'
5277       include 'COMMON.INTERACT'
5278       include 'COMMON.DERIV'
5279       include 'COMMON.VAR'
5280       include 'COMMON.CHAIN'
5281       include 'COMMON.IOUNITS'
5282       include 'COMMON.NAMES'
5283       include 'COMMON.FFIELD'
5284       include 'COMMON.TORCNSTR'
5285       common /calcthet/ term1,term2,termm,diffak,ratak,
5286      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5287      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5288       double precision y(2),z(2)
5289       delta=0.02d0*pi
5290 c      time11=dexp(-2*time)
5291 c      time12=1.0d0
5292       etheta=0.0D0
5293 c      write (iout,*) "nres",nres
5294 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5295 c      write (iout,*) ithet_start,ithet_end
5296       do i=ithet_start,ithet_end
5297 C        if (itype(i-1).eq.ntyp1) cycle
5298         if (i.le.2) cycle
5299         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5300      &  .or.itype(i).eq.ntyp1) cycle
5301 C Zero the energy function and its derivative at 0 or pi.
5302         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5303         it=itype(i-1)
5304         ichir1=isign(1,itype(i-2))
5305         ichir2=isign(1,itype(i))
5306          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5307          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5308          if (itype(i-1).eq.10) then
5309           itype1=isign(10,itype(i-2))
5310           ichir11=isign(1,itype(i-2))
5311           ichir12=isign(1,itype(i-2))
5312           itype2=isign(10,itype(i))
5313           ichir21=isign(1,itype(i))
5314           ichir22=isign(1,itype(i))
5315          endif
5316          if (i.eq.3) then
5317           y(1)=0.0D0
5318           y(2)=0.0D0
5319           else
5320
5321         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5322 #ifdef OSF
5323           phii=phi(i)
5324 c          icrc=0
5325 c          call proc_proc(phii,icrc)
5326           if (icrc.eq.1) phii=150.0
5327 #else
5328           phii=phi(i)
5329 #endif
5330           y(1)=dcos(phii)
5331           y(2)=dsin(phii)
5332         else
5333           y(1)=0.0D0
5334           y(2)=0.0D0
5335         endif
5336         endif
5337         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5338 #ifdef OSF
5339           phii1=phi(i+1)
5340 c          icrc=0
5341 c          call proc_proc(phii1,icrc)
5342           if (icrc.eq.1) phii1=150.0
5343           phii1=pinorm(phii1)
5344           z(1)=cos(phii1)
5345 #else
5346           phii1=phi(i+1)
5347           z(1)=dcos(phii1)
5348 #endif
5349           z(2)=dsin(phii1)
5350         else
5351           z(1)=0.0D0
5352           z(2)=0.0D0
5353         endif
5354 C Calculate the "mean" value of theta from the part of the distribution
5355 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5356 C In following comments this theta will be referred to as t_c.
5357         thet_pred_mean=0.0d0
5358         do k=1,2
5359             athetk=athet(k,it,ichir1,ichir2)
5360             bthetk=bthet(k,it,ichir1,ichir2)
5361           if (it.eq.10) then
5362              athetk=athet(k,itype1,ichir11,ichir12)
5363              bthetk=bthet(k,itype2,ichir21,ichir22)
5364           endif
5365           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5366         enddo
5367 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5368         dthett=thet_pred_mean*ssd
5369         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5370 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5371 C Derivatives of the "mean" values in gamma1 and gamma2.
5372         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5373      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5374          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5375      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5376          if (it.eq.10) then
5377       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5378      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5379         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5380      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5381          endif
5382         if (theta(i).gt.pi-delta) then
5383           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5384      &         E_tc0)
5385           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5386           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5387           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5388      &        E_theta)
5389           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5390      &        E_tc)
5391         else if (theta(i).lt.delta) then
5392           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5393           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5394           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5395      &        E_theta)
5396           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5397           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5398      &        E_tc)
5399         else
5400           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5401      &        E_theta,E_tc)
5402         endif
5403         etheta=etheta+ethetai
5404 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5405 c     &      'ebend',i,ethetai,theta(i),itype(i)
5406 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5407 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5408         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5409         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5410         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5411 c 1215   continue
5412       enddo
5413       ethetacnstr=0.0d0
5414 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5415       do i=1,ntheta_constr
5416         itheta=itheta_constr(i)
5417         thetiii=theta(itheta)
5418         difi=pinorm(thetiii-theta_constr0(i))
5419         if (difi.gt.theta_drange(i)) then
5420           difi=difi-theta_drange(i)
5421           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5422           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5423      &    +for_thet_constr(i)*difi**3
5424         else if (difi.lt.-drange(i)) then
5425           difi=difi+drange(i)
5426           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5427           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5428      &    +for_thet_constr(i)*difi**3
5429         else
5430           difi=0.0
5431         endif
5432 C       if (energy_dec) then
5433 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5434 C     &    i,itheta,rad2deg*thetiii,
5435 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5436 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5437 C     &    gloc(itheta+nphi-2,icg)
5438 C        endif
5439       enddo
5440 C Ufff.... We've done all this!!!
5441       return
5442       end
5443 C---------------------------------------------------------------------------
5444       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5445      &     E_tc)
5446       implicit real*8 (a-h,o-z)
5447       include 'DIMENSIONS'
5448       include 'COMMON.LOCAL'
5449       include 'COMMON.IOUNITS'
5450       common /calcthet/ term1,term2,termm,diffak,ratak,
5451      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5452      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5453 C Calculate the contributions to both Gaussian lobes.
5454 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5455 C The "polynomial part" of the "standard deviation" of this part of
5456 C the distribution.
5457         sig=polthet(3,it)
5458         do j=2,0,-1
5459           sig=sig*thet_pred_mean+polthet(j,it)
5460         enddo
5461 C Derivative of the "interior part" of the "standard deviation of the"
5462 C gamma-dependent Gaussian lobe in t_c.
5463         sigtc=3*polthet(3,it)
5464         do j=2,1,-1
5465           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5466         enddo
5467         sigtc=sig*sigtc
5468 C Set the parameters of both Gaussian lobes of the distribution.
5469 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5470         fac=sig*sig+sigc0(it)
5471         sigcsq=fac+fac
5472         sigc=1.0D0/sigcsq
5473 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5474         sigsqtc=-4.0D0*sigcsq*sigtc
5475 c       print *,i,sig,sigtc,sigsqtc
5476 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5477         sigtc=-sigtc/(fac*fac)
5478 C Following variable is sigma(t_c)**(-2)
5479         sigcsq=sigcsq*sigcsq
5480         sig0i=sig0(it)
5481         sig0inv=1.0D0/sig0i**2
5482         delthec=thetai-thet_pred_mean
5483         delthe0=thetai-theta0i
5484         term1=-0.5D0*sigcsq*delthec*delthec
5485         term2=-0.5D0*sig0inv*delthe0*delthe0
5486 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5487 C NaNs in taking the logarithm. We extract the largest exponent which is added
5488 C to the energy (this being the log of the distribution) at the end of energy
5489 C term evaluation for this virtual-bond angle.
5490         if (term1.gt.term2) then
5491           termm=term1
5492           term2=dexp(term2-termm)
5493           term1=1.0d0
5494         else
5495           termm=term2
5496           term1=dexp(term1-termm)
5497           term2=1.0d0
5498         endif
5499 C The ratio between the gamma-independent and gamma-dependent lobes of
5500 C the distribution is a Gaussian function of thet_pred_mean too.
5501         diffak=gthet(2,it)-thet_pred_mean
5502         ratak=diffak/gthet(3,it)**2
5503         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5504 C Let's differentiate it in thet_pred_mean NOW.
5505         aktc=ak*ratak
5506 C Now put together the distribution terms to make complete distribution.
5507         termexp=term1+ak*term2
5508         termpre=sigc+ak*sig0i
5509 C Contribution of the bending energy from this theta is just the -log of
5510 C the sum of the contributions from the two lobes and the pre-exponential
5511 C factor. Simple enough, isn't it?
5512         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5513 C NOW the derivatives!!!
5514 C 6/6/97 Take into account the deformation.
5515         E_theta=(delthec*sigcsq*term1
5516      &       +ak*delthe0*sig0inv*term2)/termexp
5517         E_tc=((sigtc+aktc*sig0i)/termpre
5518      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5519      &       aktc*term2)/termexp)
5520       return
5521       end
5522 c-----------------------------------------------------------------------------
5523       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5524       implicit real*8 (a-h,o-z)
5525       include 'DIMENSIONS'
5526       include 'COMMON.LOCAL'
5527       include 'COMMON.IOUNITS'
5528       common /calcthet/ term1,term2,termm,diffak,ratak,
5529      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5530      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5531       delthec=thetai-thet_pred_mean
5532       delthe0=thetai-theta0i
5533 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5534       t3 = thetai-thet_pred_mean
5535       t6 = t3**2
5536       t9 = term1
5537       t12 = t3*sigcsq
5538       t14 = t12+t6*sigsqtc
5539       t16 = 1.0d0
5540       t21 = thetai-theta0i
5541       t23 = t21**2
5542       t26 = term2
5543       t27 = t21*t26
5544       t32 = termexp
5545       t40 = t32**2
5546       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5547      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5548      & *(-t12*t9-ak*sig0inv*t27)
5549       return
5550       end
5551 #else
5552 C--------------------------------------------------------------------------
5553       subroutine ebend(etheta)
5554 C
5555 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5556 C angles gamma and its derivatives in consecutive thetas and gammas.
5557 C ab initio-derived potentials from
5558 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5559 C
5560       implicit real*8 (a-h,o-z)
5561       include 'DIMENSIONS'
5562       include 'DIMENSIONS.ZSCOPT'
5563       include 'COMMON.LOCAL'
5564       include 'COMMON.GEO'
5565       include 'COMMON.INTERACT'
5566       include 'COMMON.DERIV'
5567       include 'COMMON.VAR'
5568       include 'COMMON.CHAIN'
5569       include 'COMMON.IOUNITS'
5570       include 'COMMON.NAMES'
5571       include 'COMMON.FFIELD'
5572       include 'COMMON.CONTROL'
5573       include 'COMMON.TORCNSTR'
5574       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5575      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5576      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5577      & sinph1ph2(maxdouble,maxdouble)
5578       logical lprn /.false./, lprn1 /.false./
5579       etheta=0.0D0
5580 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5581       do i=ithet_start,ithet_end
5582 C         if (i.eq.2) cycle
5583 C        if (itype(i-1).eq.ntyp1) cycle
5584         if (i.le.2) cycle
5585         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5586      &  .or.itype(i).eq.ntyp1) cycle
5587         if (iabs(itype(i+1)).eq.20) iblock=2
5588         if (iabs(itype(i+1)).ne.20) iblock=1
5589         dethetai=0.0d0
5590         dephii=0.0d0
5591         dephii1=0.0d0
5592         theti2=0.5d0*theta(i)
5593         ityp2=ithetyp((itype(i-1)))
5594         do k=1,nntheterm
5595           coskt(k)=dcos(k*theti2)
5596           sinkt(k)=dsin(k*theti2)
5597         enddo
5598 cu        if (i.eq.3) then
5599 cu          phii=0.0d0
5600 cu          ityp1=nthetyp+1
5601 cu          do k=1,nsingle
5602 cu            cosph1(k)=0.0d0
5603 cu            sinph1(k)=0.0d0
5604 cu          enddo
5605 cu        else
5606         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5607 #ifdef OSF
5608           phii=phi(i)
5609           if (phii.ne.phii) phii=150.0
5610 #else
5611           phii=phi(i)
5612 #endif
5613           ityp1=ithetyp((itype(i-2)))
5614           do k=1,nsingle
5615             cosph1(k)=dcos(k*phii)
5616             sinph1(k)=dsin(k*phii)
5617           enddo
5618         else
5619           phii=0.0d0
5620 c          ityp1=nthetyp+1
5621           do k=1,nsingle
5622             ityp1=ithetyp((itype(i-2)))
5623             cosph1(k)=0.0d0
5624             sinph1(k)=0.0d0
5625           enddo
5626         endif
5627         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5628 #ifdef OSF
5629           phii1=phi(i+1)
5630           if (phii1.ne.phii1) phii1=150.0
5631           phii1=pinorm(phii1)
5632 #else
5633           phii1=phi(i+1)
5634 #endif
5635           ityp3=ithetyp((itype(i)))
5636           do k=1,nsingle
5637             cosph2(k)=dcos(k*phii1)
5638             sinph2(k)=dsin(k*phii1)
5639           enddo
5640         else
5641           phii1=0.0d0
5642 c          ityp3=nthetyp+1
5643           ityp3=ithetyp((itype(i)))
5644           do k=1,nsingle
5645             cosph2(k)=0.0d0
5646             sinph2(k)=0.0d0
5647           enddo
5648         endif
5649 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5650 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5651 c        call flush(iout)
5652         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5653         do k=1,ndouble
5654           do l=1,k-1
5655             ccl=cosph1(l)*cosph2(k-l)
5656             ssl=sinph1(l)*sinph2(k-l)
5657             scl=sinph1(l)*cosph2(k-l)
5658             csl=cosph1(l)*sinph2(k-l)
5659             cosph1ph2(l,k)=ccl-ssl
5660             cosph1ph2(k,l)=ccl+ssl
5661             sinph1ph2(l,k)=scl+csl
5662             sinph1ph2(k,l)=scl-csl
5663           enddo
5664         enddo
5665         if (lprn) then
5666         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5667      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5668         write (iout,*) "coskt and sinkt"
5669         do k=1,nntheterm
5670           write (iout,*) k,coskt(k),sinkt(k)
5671         enddo
5672         endif
5673         do k=1,ntheterm
5674           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5675           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5676      &      *coskt(k)
5677           if (lprn)
5678      &    write (iout,*) "k",k,"
5679      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5680      &     " ethetai",ethetai
5681         enddo
5682         if (lprn) then
5683         write (iout,*) "cosph and sinph"
5684         do k=1,nsingle
5685           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5686         enddo
5687         write (iout,*) "cosph1ph2 and sinph2ph2"
5688         do k=2,ndouble
5689           do l=1,k-1
5690             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5691      &         sinph1ph2(l,k),sinph1ph2(k,l)
5692           enddo
5693         enddo
5694         write(iout,*) "ethetai",ethetai
5695         endif
5696         do m=1,ntheterm2
5697           do k=1,nsingle
5698             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5699      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5700      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5701      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5702             ethetai=ethetai+sinkt(m)*aux
5703             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5704             dephii=dephii+k*sinkt(m)*(
5705      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5706      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5707             dephii1=dephii1+k*sinkt(m)*(
5708      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5709      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5710             if (lprn)
5711      &      write (iout,*) "m",m," k",k," bbthet",
5712      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5713      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5714      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5715      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5716           enddo
5717         enddo
5718         if (lprn)
5719      &  write(iout,*) "ethetai",ethetai
5720         do m=1,ntheterm3
5721           do k=2,ndouble
5722             do l=1,k-1
5723               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5724      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5725      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5726      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5727               ethetai=ethetai+sinkt(m)*aux
5728               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5729               dephii=dephii+l*sinkt(m)*(
5730      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5731      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5732      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5733      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5734               dephii1=dephii1+(k-l)*sinkt(m)*(
5735      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5736      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5737      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5738      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5739               if (lprn) then
5740               write (iout,*) "m",m," k",k," l",l," ffthet",
5741      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5742      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5743      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5744      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5745      &            " ethetai",ethetai
5746               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5747      &            cosph1ph2(k,l)*sinkt(m),
5748      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5749               endif
5750             enddo
5751           enddo
5752         enddo
5753 10      continue
5754         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5755      &   i,theta(i)*rad2deg,phii*rad2deg,
5756      &   phii1*rad2deg,ethetai
5757         etheta=etheta+ethetai
5758         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5759         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5760 c        gloc(nphi+i-2,icg)=wang*dethetai
5761         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5762       enddo
5763       return
5764       end
5765 #endif
5766 #ifdef CRYST_SC
5767 c-----------------------------------------------------------------------------
5768       subroutine esc(escloc)
5769 C Calculate the local energy of a side chain and its derivatives in the
5770 C corresponding virtual-bond valence angles THETA and the spherical angles
5771 C ALPHA and OMEGA.
5772       implicit real*8 (a-h,o-z)
5773       include 'DIMENSIONS'
5774       include 'DIMENSIONS.ZSCOPT'
5775       include 'COMMON.GEO'
5776       include 'COMMON.LOCAL'
5777       include 'COMMON.VAR'
5778       include 'COMMON.INTERACT'
5779       include 'COMMON.DERIV'
5780       include 'COMMON.CHAIN'
5781       include 'COMMON.IOUNITS'
5782       include 'COMMON.NAMES'
5783       include 'COMMON.FFIELD'
5784       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5785      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5786       common /sccalc/ time11,time12,time112,theti,it,nlobit
5787       delta=0.02d0*pi
5788       escloc=0.0D0
5789 C      write (iout,*) 'ESC'
5790       do i=loc_start,loc_end
5791         it=itype(i)
5792         if (it.eq.ntyp1) cycle
5793         if (it.eq.10) goto 1
5794         nlobit=nlob(iabs(it))
5795 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5796 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5797         theti=theta(i+1)-pipol
5798         x(1)=dtan(theti)
5799         x(2)=alph(i)
5800         x(3)=omeg(i)
5801 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5802
5803         if (x(2).gt.pi-delta) then
5804           xtemp(1)=x(1)
5805           xtemp(2)=pi-delta
5806           xtemp(3)=x(3)
5807           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5808           xtemp(2)=pi
5809           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5810           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5811      &        escloci,dersc(2))
5812           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5813      &        ddersc0(1),dersc(1))
5814           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5815      &        ddersc0(3),dersc(3))
5816           xtemp(2)=pi-delta
5817           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5818           xtemp(2)=pi
5819           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5820           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5821      &            dersc0(2),esclocbi,dersc02)
5822           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5823      &            dersc12,dersc01)
5824           call splinthet(x(2),0.5d0*delta,ss,ssd)
5825           dersc0(1)=dersc01
5826           dersc0(2)=dersc02
5827           dersc0(3)=0.0d0
5828           do k=1,3
5829             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5830           enddo
5831           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5832           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5833      &             esclocbi,ss,ssd
5834           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5835 c         escloci=esclocbi
5836 c         write (iout,*) escloci
5837         else if (x(2).lt.delta) then
5838           xtemp(1)=x(1)
5839           xtemp(2)=delta
5840           xtemp(3)=x(3)
5841           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5842           xtemp(2)=0.0d0
5843           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5844           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5845      &        escloci,dersc(2))
5846           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5847      &        ddersc0(1),dersc(1))
5848           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5849      &        ddersc0(3),dersc(3))
5850           xtemp(2)=delta
5851           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5852           xtemp(2)=0.0d0
5853           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5854           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5855      &            dersc0(2),esclocbi,dersc02)
5856           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5857      &            dersc12,dersc01)
5858           dersc0(1)=dersc01
5859           dersc0(2)=dersc02
5860           dersc0(3)=0.0d0
5861           call splinthet(x(2),0.5d0*delta,ss,ssd)
5862           do k=1,3
5863             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5864           enddo
5865           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5866 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5867 c     &             esclocbi,ss,ssd
5868           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5869 C         write (iout,*) 'i=',i, escloci
5870         else
5871           call enesc(x,escloci,dersc,ddummy,.false.)
5872         endif
5873
5874         escloc=escloc+escloci
5875 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5876             write (iout,'(a6,i5,0pf7.3)')
5877      &     'escloc',i,escloci
5878
5879         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5880      &   wscloc*dersc(1)
5881         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5882         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5883     1   continue
5884       enddo
5885       return
5886       end
5887 C---------------------------------------------------------------------------
5888       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5889       implicit real*8 (a-h,o-z)
5890       include 'DIMENSIONS'
5891       include 'COMMON.GEO'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.IOUNITS'
5894       common /sccalc/ time11,time12,time112,theti,it,nlobit
5895       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5896       double precision contr(maxlob,-1:1)
5897       logical mixed
5898 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5899         escloc_i=0.0D0
5900         do j=1,3
5901           dersc(j)=0.0D0
5902           if (mixed) ddersc(j)=0.0d0
5903         enddo
5904         x3=x(3)
5905
5906 C Because of periodicity of the dependence of the SC energy in omega we have
5907 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5908 C To avoid underflows, first compute & store the exponents.
5909
5910         do iii=-1,1
5911
5912           x(3)=x3+iii*dwapi
5913
5914           do j=1,nlobit
5915             do k=1,3
5916               z(k)=x(k)-censc(k,j,it)
5917             enddo
5918             do k=1,3
5919               Axk=0.0D0
5920               do l=1,3
5921                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5922               enddo
5923               Ax(k,j,iii)=Axk
5924             enddo
5925             expfac=0.0D0
5926             do k=1,3
5927               expfac=expfac+Ax(k,j,iii)*z(k)
5928             enddo
5929             contr(j,iii)=expfac
5930           enddo ! j
5931
5932         enddo ! iii
5933
5934         x(3)=x3
5935 C As in the case of ebend, we want to avoid underflows in exponentiation and
5936 C subsequent NaNs and INFs in energy calculation.
5937 C Find the largest exponent
5938         emin=contr(1,-1)
5939         do iii=-1,1
5940           do j=1,nlobit
5941             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5942           enddo
5943         enddo
5944         emin=0.5D0*emin
5945 cd      print *,'it=',it,' emin=',emin
5946
5947 C Compute the contribution to SC energy and derivatives
5948         do iii=-1,1
5949
5950           do j=1,nlobit
5951             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5952 cd          print *,'j=',j,' expfac=',expfac
5953             escloc_i=escloc_i+expfac
5954             do k=1,3
5955               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5956             enddo
5957             if (mixed) then
5958               do k=1,3,2
5959                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5960      &            +gaussc(k,2,j,it))*expfac
5961               enddo
5962             endif
5963           enddo
5964
5965         enddo ! iii
5966
5967         dersc(1)=dersc(1)/cos(theti)**2
5968         ddersc(1)=ddersc(1)/cos(theti)**2
5969         ddersc(3)=ddersc(3)
5970
5971         escloci=-(dlog(escloc_i)-emin)
5972         do j=1,3
5973           dersc(j)=dersc(j)/escloc_i
5974         enddo
5975         if (mixed) then
5976           do j=1,3,2
5977             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5978           enddo
5979         endif
5980       return
5981       end
5982 C------------------------------------------------------------------------------
5983       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5984       implicit real*8 (a-h,o-z)
5985       include 'DIMENSIONS'
5986       include 'COMMON.GEO'
5987       include 'COMMON.LOCAL'
5988       include 'COMMON.IOUNITS'
5989       common /sccalc/ time11,time12,time112,theti,it,nlobit
5990       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5991       double precision contr(maxlob)
5992       logical mixed
5993
5994       escloc_i=0.0D0
5995
5996       do j=1,3
5997         dersc(j)=0.0D0
5998       enddo
5999
6000       do j=1,nlobit
6001         do k=1,2
6002           z(k)=x(k)-censc(k,j,it)
6003         enddo
6004         z(3)=dwapi
6005         do k=1,3
6006           Axk=0.0D0
6007           do l=1,3
6008             Axk=Axk+gaussc(l,k,j,it)*z(l)
6009           enddo
6010           Ax(k,j)=Axk
6011         enddo
6012         expfac=0.0D0
6013         do k=1,3
6014           expfac=expfac+Ax(k,j)*z(k)
6015         enddo
6016         contr(j)=expfac
6017       enddo ! j
6018
6019 C As in the case of ebend, we want to avoid underflows in exponentiation and
6020 C subsequent NaNs and INFs in energy calculation.
6021 C Find the largest exponent
6022       emin=contr(1)
6023       do j=1,nlobit
6024         if (emin.gt.contr(j)) emin=contr(j)
6025       enddo
6026       emin=0.5D0*emin
6027
6028 C Compute the contribution to SC energy and derivatives
6029
6030       dersc12=0.0d0
6031       do j=1,nlobit
6032         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6033         escloc_i=escloc_i+expfac
6034         do k=1,2
6035           dersc(k)=dersc(k)+Ax(k,j)*expfac
6036         enddo
6037         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6038      &            +gaussc(1,2,j,it))*expfac
6039         dersc(3)=0.0d0
6040       enddo
6041
6042       dersc(1)=dersc(1)/cos(theti)**2
6043       dersc12=dersc12/cos(theti)**2
6044       escloci=-(dlog(escloc_i)-emin)
6045       do j=1,2
6046         dersc(j)=dersc(j)/escloc_i
6047       enddo
6048       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6049       return
6050       end
6051 #else
6052 c----------------------------------------------------------------------------------
6053       subroutine esc(escloc)
6054 C Calculate the local energy of a side chain and its derivatives in the
6055 C corresponding virtual-bond valence angles THETA and the spherical angles
6056 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6057 C added by Urszula Kozlowska. 07/11/2007
6058 C
6059       implicit real*8 (a-h,o-z)
6060       include 'DIMENSIONS'
6061       include 'DIMENSIONS.ZSCOPT'
6062       include 'COMMON.GEO'
6063       include 'COMMON.LOCAL'
6064       include 'COMMON.VAR'
6065       include 'COMMON.SCROT'
6066       include 'COMMON.INTERACT'
6067       include 'COMMON.DERIV'
6068       include 'COMMON.CHAIN'
6069       include 'COMMON.IOUNITS'
6070       include 'COMMON.NAMES'
6071       include 'COMMON.FFIELD'
6072       include 'COMMON.CONTROL'
6073       include 'COMMON.VECTORS'
6074       double precision x_prime(3),y_prime(3),z_prime(3)
6075      &    , sumene,dsc_i,dp2_i,x(65),
6076      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6077      &    de_dxx,de_dyy,de_dzz,de_dt
6078       double precision s1_t,s1_6_t,s2_t,s2_6_t
6079       double precision
6080      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6081      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6082      & dt_dCi(3),dt_dCi1(3)
6083       common /sccalc/ time11,time12,time112,theti,it,nlobit
6084       delta=0.02d0*pi
6085       escloc=0.0D0
6086       do i=loc_start,loc_end
6087         if (itype(i).eq.ntyp1) cycle
6088         costtab(i+1) =dcos(theta(i+1))
6089         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6090         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6091         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6092         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6093         cosfac=dsqrt(cosfac2)
6094         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6095         sinfac=dsqrt(sinfac2)
6096         it=iabs(itype(i))
6097         if (it.eq.10) goto 1
6098 c
6099 C  Compute the axes of tghe local cartesian coordinates system; store in
6100 c   x_prime, y_prime and z_prime
6101 c
6102         do j=1,3
6103           x_prime(j) = 0.00
6104           y_prime(j) = 0.00
6105           z_prime(j) = 0.00
6106         enddo
6107 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6108 C     &   dc_norm(3,i+nres)
6109         do j = 1,3
6110           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6111           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6112         enddo
6113         do j = 1,3
6114           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6115         enddo
6116 c       write (2,*) "i",i
6117 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6118 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6119 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6120 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6121 c      & " xy",scalar(x_prime(1),y_prime(1)),
6122 c      & " xz",scalar(x_prime(1),z_prime(1)),
6123 c      & " yy",scalar(y_prime(1),y_prime(1)),
6124 c      & " yz",scalar(y_prime(1),z_prime(1)),
6125 c      & " zz",scalar(z_prime(1),z_prime(1))
6126 c
6127 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6128 C to local coordinate system. Store in xx, yy, zz.
6129 c
6130         xx=0.0d0
6131         yy=0.0d0
6132         zz=0.0d0
6133         do j = 1,3
6134           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6135           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6136           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6137         enddo
6138
6139         xxtab(i)=xx
6140         yytab(i)=yy
6141         zztab(i)=zz
6142 C
6143 C Compute the energy of the ith side cbain
6144 C
6145 c        write (2,*) "xx",xx," yy",yy," zz",zz
6146         it=iabs(itype(i))
6147         do j = 1,65
6148           x(j) = sc_parmin(j,it)
6149         enddo
6150 #ifdef CHECK_COORD
6151 Cc diagnostics - remove later
6152         xx1 = dcos(alph(2))
6153         yy1 = dsin(alph(2))*dcos(omeg(2))
6154         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6155         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6156      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6157      &    xx1,yy1,zz1
6158 C,"  --- ", xx_w,yy_w,zz_w
6159 c end diagnostics
6160 #endif
6161         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6162      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6163      &   + x(10)*yy*zz
6164         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6165      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6166      & + x(20)*yy*zz
6167         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6168      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6169      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6170      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6171      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6172      &  +x(40)*xx*yy*zz
6173         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6174      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6175      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6176      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6177      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6178      &  +x(60)*xx*yy*zz
6179         dsc_i   = 0.743d0+x(61)
6180         dp2_i   = 1.9d0+x(62)
6181         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6182      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6183         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6184      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6185         s1=(1+x(63))/(0.1d0 + dscp1)
6186         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6187         s2=(1+x(65))/(0.1d0 + dscp2)
6188         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6189         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6190      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6191 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6192 c     &   sumene4,
6193 c     &   dscp1,dscp2,sumene
6194 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6195         escloc = escloc + sumene
6196 c        write (2,*) "escloc",escloc
6197 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6198 c     &  zz,xx,yy
6199         if (.not. calc_grad) goto 1
6200 #ifdef DEBUG
6201 C
6202 C This section to check the numerical derivatives of the energy of ith side
6203 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6204 C #define DEBUG in the code to turn it on.
6205 C
6206         write (2,*) "sumene               =",sumene
6207         aincr=1.0d-7
6208         xxsave=xx
6209         xx=xx+aincr
6210         write (2,*) xx,yy,zz
6211         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6212         de_dxx_num=(sumenep-sumene)/aincr
6213         xx=xxsave
6214         write (2,*) "xx+ sumene from enesc=",sumenep
6215         yysave=yy
6216         yy=yy+aincr
6217         write (2,*) xx,yy,zz
6218         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6219         de_dyy_num=(sumenep-sumene)/aincr
6220         yy=yysave
6221         write (2,*) "yy+ sumene from enesc=",sumenep
6222         zzsave=zz
6223         zz=zz+aincr
6224         write (2,*) xx,yy,zz
6225         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6226         de_dzz_num=(sumenep-sumene)/aincr
6227         zz=zzsave
6228         write (2,*) "zz+ sumene from enesc=",sumenep
6229         costsave=cost2tab(i+1)
6230         sintsave=sint2tab(i+1)
6231         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6232         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6233         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6234         de_dt_num=(sumenep-sumene)/aincr
6235         write (2,*) " t+ sumene from enesc=",sumenep
6236         cost2tab(i+1)=costsave
6237         sint2tab(i+1)=sintsave
6238 C End of diagnostics section.
6239 #endif
6240 C
6241 C Compute the gradient of esc
6242 C
6243         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6244         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6245         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6246         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6247         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6248         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6249         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6250         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6251         pom1=(sumene3*sint2tab(i+1)+sumene1)
6252      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6253         pom2=(sumene4*cost2tab(i+1)+sumene2)
6254      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6255         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6256         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6257      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6258      &  +x(40)*yy*zz
6259         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6260         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6261      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6262      &  +x(60)*yy*zz
6263         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6264      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6265      &        +(pom1+pom2)*pom_dx
6266 #ifdef DEBUG
6267         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6268 #endif
6269 C
6270         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6271         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6272      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6273      &  +x(40)*xx*zz
6274         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6275         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6276      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6277      &  +x(59)*zz**2 +x(60)*xx*zz
6278         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6279      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6280      &        +(pom1-pom2)*pom_dy
6281 #ifdef DEBUG
6282         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6283 #endif
6284 C
6285         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6286      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6287      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6288      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6289      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6290      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6291      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6292      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6293 #ifdef DEBUG
6294         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6295 #endif
6296 C
6297         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6298      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6299      &  +pom1*pom_dt1+pom2*pom_dt2
6300 #ifdef DEBUG
6301         write(2,*), "de_dt = ", de_dt,de_dt_num
6302 #endif
6303 c
6304 C
6305        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6306        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6307        cosfac2xx=cosfac2*xx
6308        sinfac2yy=sinfac2*yy
6309        do k = 1,3
6310          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6311      &      vbld_inv(i+1)
6312          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6313      &      vbld_inv(i)
6314          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6315          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6316 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6317 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6318 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6319 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6320          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6321          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6322          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6323          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6324          dZZ_Ci1(k)=0.0d0
6325          dZZ_Ci(k)=0.0d0
6326          do j=1,3
6327            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6328      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6329            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6330      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6331          enddo
6332
6333          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6334          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6335          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6336 c
6337          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6338          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6339        enddo
6340
6341        do k=1,3
6342          dXX_Ctab(k,i)=dXX_Ci(k)
6343          dXX_C1tab(k,i)=dXX_Ci1(k)
6344          dYY_Ctab(k,i)=dYY_Ci(k)
6345          dYY_C1tab(k,i)=dYY_Ci1(k)
6346          dZZ_Ctab(k,i)=dZZ_Ci(k)
6347          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6348          dXX_XYZtab(k,i)=dXX_XYZ(k)
6349          dYY_XYZtab(k,i)=dYY_XYZ(k)
6350          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6351        enddo
6352
6353        do k = 1,3
6354 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6355 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6356 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6357 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6358 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6359 c     &    dt_dci(k)
6360 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6361 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6362          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6363      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6364          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6365      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6366          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6367      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6368        enddo
6369 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6370 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6371
6372 C to check gradient call subroutine check_grad
6373
6374     1 continue
6375       enddo
6376       return
6377       end
6378 #endif
6379 c------------------------------------------------------------------------------
6380       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6381 C
6382 C This procedure calculates two-body contact function g(rij) and its derivative:
6383 C
6384 C           eps0ij                                     !       x < -1
6385 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6386 C            0                                         !       x > 1
6387 C
6388 C where x=(rij-r0ij)/delta
6389 C
6390 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6391 C
6392       implicit none
6393       double precision rij,r0ij,eps0ij,fcont,fprimcont
6394       double precision x,x2,x4,delta
6395 c     delta=0.02D0*r0ij
6396 c      delta=0.2D0*r0ij
6397       x=(rij-r0ij)/delta
6398       if (x.lt.-1.0D0) then
6399         fcont=eps0ij
6400         fprimcont=0.0D0
6401       else if (x.le.1.0D0) then
6402         x2=x*x
6403         x4=x2*x2
6404         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6405         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6406       else
6407         fcont=0.0D0
6408         fprimcont=0.0D0
6409       endif
6410       return
6411       end
6412 c------------------------------------------------------------------------------
6413       subroutine splinthet(theti,delta,ss,ssder)
6414       implicit real*8 (a-h,o-z)
6415       include 'DIMENSIONS'
6416       include 'DIMENSIONS.ZSCOPT'
6417       include 'COMMON.VAR'
6418       include 'COMMON.GEO'
6419       thetup=pi-delta
6420       thetlow=delta
6421       if (theti.gt.pipol) then
6422         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6423       else
6424         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6425         ssder=-ssder
6426       endif
6427       return
6428       end
6429 c------------------------------------------------------------------------------
6430       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6431       implicit none
6432       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6433       double precision ksi,ksi2,ksi3,a1,a2,a3
6434       a1=fprim0*delta/(f1-f0)
6435       a2=3.0d0-2.0d0*a1
6436       a3=a1-2.0d0
6437       ksi=(x-x0)/delta
6438       ksi2=ksi*ksi
6439       ksi3=ksi2*ksi
6440       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6441       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6442       return
6443       end
6444 c------------------------------------------------------------------------------
6445       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6446       implicit none
6447       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6448       double precision ksi,ksi2,ksi3,a1,a2,a3
6449       ksi=(x-x0)/delta
6450       ksi2=ksi*ksi
6451       ksi3=ksi2*ksi
6452       a1=fprim0x*delta
6453       a2=3*(f1x-f0x)-2*fprim0x*delta
6454       a3=fprim0x*delta-2*(f1x-f0x)
6455       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6456       return
6457       end
6458 C-----------------------------------------------------------------------------
6459 #ifdef CRYST_TOR
6460 C-----------------------------------------------------------------------------
6461       subroutine etor(etors,fact)
6462       implicit real*8 (a-h,o-z)
6463       include 'DIMENSIONS'
6464       include 'DIMENSIONS.ZSCOPT'
6465       include 'COMMON.VAR'
6466       include 'COMMON.GEO'
6467       include 'COMMON.LOCAL'
6468       include 'COMMON.TORSION'
6469       include 'COMMON.INTERACT'
6470       include 'COMMON.DERIV'
6471       include 'COMMON.CHAIN'
6472       include 'COMMON.NAMES'
6473       include 'COMMON.IOUNITS'
6474       include 'COMMON.FFIELD'
6475       include 'COMMON.TORCNSTR'
6476       logical lprn
6477 C Set lprn=.true. for debugging
6478       lprn=.false.
6479 c      lprn=.true.
6480       etors=0.0D0
6481       do i=iphi_start,iphi_end
6482         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6483      &      .or. itype(i).eq.ntyp1) cycle
6484         itori=itortyp(itype(i-2))
6485         itori1=itortyp(itype(i-1))
6486         phii=phi(i)
6487         gloci=0.0D0
6488 C Proline-Proline pair is a special case...
6489         if (itori.eq.3 .and. itori1.eq.3) then
6490           if (phii.gt.-dwapi3) then
6491             cosphi=dcos(3*phii)
6492             fac=1.0D0/(1.0D0-cosphi)
6493             etorsi=v1(1,3,3)*fac
6494             etorsi=etorsi+etorsi
6495             etors=etors+etorsi-v1(1,3,3)
6496             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6497           endif
6498           do j=1,3
6499             v1ij=v1(j+1,itori,itori1)
6500             v2ij=v2(j+1,itori,itori1)
6501             cosphi=dcos(j*phii)
6502             sinphi=dsin(j*phii)
6503             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6504             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6505           enddo
6506         else
6507           do j=1,nterm_old
6508             v1ij=v1(j,itori,itori1)
6509             v2ij=v2(j,itori,itori1)
6510             cosphi=dcos(j*phii)
6511             sinphi=dsin(j*phii)
6512             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6513             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6514           enddo
6515         endif
6516         if (lprn)
6517      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6518      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6519      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6520         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6521 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6522       enddo
6523       return
6524       end
6525 c------------------------------------------------------------------------------
6526 #else
6527       subroutine etor(etors,fact)
6528       implicit real*8 (a-h,o-z)
6529       include 'DIMENSIONS'
6530       include 'DIMENSIONS.ZSCOPT'
6531       include 'COMMON.VAR'
6532       include 'COMMON.GEO'
6533       include 'COMMON.LOCAL'
6534       include 'COMMON.TORSION'
6535       include 'COMMON.INTERACT'
6536       include 'COMMON.DERIV'
6537       include 'COMMON.CHAIN'
6538       include 'COMMON.NAMES'
6539       include 'COMMON.IOUNITS'
6540       include 'COMMON.FFIELD'
6541       include 'COMMON.TORCNSTR'
6542       logical lprn
6543 C Set lprn=.true. for debugging
6544       lprn=.false.
6545 c      lprn=.true.
6546       etors=0.0D0
6547       do i=iphi_start,iphi_end
6548         if (i.le.2) cycle
6549         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6550      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6551 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6552 C     &       .or. itype(i).eq.ntyp1) cycle
6553         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6554          if (iabs(itype(i)).eq.20) then
6555          iblock=2
6556          else
6557          iblock=1
6558          endif
6559         itori=itortyp(itype(i-2))
6560         itori1=itortyp(itype(i-1))
6561         phii=phi(i)
6562         gloci=0.0D0
6563 C Regular cosine and sine terms
6564         do j=1,nterm(itori,itori1,iblock)
6565           v1ij=v1(j,itori,itori1,iblock)
6566           v2ij=v2(j,itori,itori1,iblock)
6567           cosphi=dcos(j*phii)
6568           sinphi=dsin(j*phii)
6569           etors=etors+v1ij*cosphi+v2ij*sinphi
6570           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6571         enddo
6572 C Lorentz terms
6573 C                         v1
6574 C  E = SUM ----------------------------------- - v1
6575 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6576 C
6577         cosphi=dcos(0.5d0*phii)
6578         sinphi=dsin(0.5d0*phii)
6579         do j=1,nlor(itori,itori1,iblock)
6580           vl1ij=vlor1(j,itori,itori1)
6581           vl2ij=vlor2(j,itori,itori1)
6582           vl3ij=vlor3(j,itori,itori1)
6583           pom=vl2ij*cosphi+vl3ij*sinphi
6584           pom1=1.0d0/(pom*pom+1.0d0)
6585           etors=etors+vl1ij*pom1
6586 c          if (energy_dec) etors_ii=etors_ii+
6587 c     &                vl1ij*pom1
6588           pom=-pom*pom1*pom1
6589           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6590         enddo
6591 C Subtract the constant term
6592         etors=etors-v0(itori,itori1,iblock)
6593         if (lprn)
6594      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6595      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6596      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6597         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6598 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6599  1215   continue
6600       enddo
6601       return
6602       end
6603 c----------------------------------------------------------------------------
6604       subroutine etor_d(etors_d,fact2)
6605 C 6/23/01 Compute double torsional energy
6606       implicit real*8 (a-h,o-z)
6607       include 'DIMENSIONS'
6608       include 'DIMENSIONS.ZSCOPT'
6609       include 'COMMON.VAR'
6610       include 'COMMON.GEO'
6611       include 'COMMON.LOCAL'
6612       include 'COMMON.TORSION'
6613       include 'COMMON.INTERACT'
6614       include 'COMMON.DERIV'
6615       include 'COMMON.CHAIN'
6616       include 'COMMON.NAMES'
6617       include 'COMMON.IOUNITS'
6618       include 'COMMON.FFIELD'
6619       include 'COMMON.TORCNSTR'
6620       logical lprn
6621 C Set lprn=.true. for debugging
6622       lprn=.false.
6623 c     lprn=.true.
6624       etors_d=0.0D0
6625       do i=iphi_start,iphi_end-1
6626         if (i.le.3) cycle
6627 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6628 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6629          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6630      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6631      &  (itype(i+1).eq.ntyp1)) cycle
6632         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6633      &     goto 1215
6634         itori=itortyp(itype(i-2))
6635         itori1=itortyp(itype(i-1))
6636         itori2=itortyp(itype(i))
6637         phii=phi(i)
6638         phii1=phi(i+1)
6639         gloci1=0.0D0
6640         gloci2=0.0D0
6641         iblock=1
6642         if (iabs(itype(i+1)).eq.20) iblock=2
6643 C Regular cosine and sine terms
6644         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6645           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6646           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6647           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6648           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6649           cosphi1=dcos(j*phii)
6650           sinphi1=dsin(j*phii)
6651           cosphi2=dcos(j*phii1)
6652           sinphi2=dsin(j*phii1)
6653           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6654      &     v2cij*cosphi2+v2sij*sinphi2
6655           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6656           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6657         enddo
6658         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6659           do l=1,k-1
6660             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6661             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6662             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6663             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6664             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6665             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6666             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6667             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6668             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6669      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6670             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6671      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6672             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6673      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6674           enddo
6675         enddo
6676         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6677         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6678  1215   continue
6679       enddo
6680       return
6681       end
6682 #endif
6683 c---------------------------------------------------------------------------
6684 C The rigorous attempt to derive energy function
6685       subroutine etor_kcc(etors,fact)
6686       implicit real*8 (a-h,o-z)
6687       include 'DIMENSIONS'
6688       include 'DIMENSIONS.ZSCOPT'
6689       include 'COMMON.VAR'
6690       include 'COMMON.GEO'
6691       include 'COMMON.LOCAL'
6692       include 'COMMON.TORSION'
6693       include 'COMMON.INTERACT'
6694       include 'COMMON.DERIV'
6695       include 'COMMON.CHAIN'
6696       include 'COMMON.NAMES'
6697       include 'COMMON.IOUNITS'
6698       include 'COMMON.FFIELD'
6699       include 'COMMON.TORCNSTR'
6700       include 'COMMON.CONTROL'
6701       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6702       logical lprn
6703 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6704 C Set lprn=.true. for debugging
6705       lprn=energy_dec
6706 c     lprn=.true.
6707 C      print *,"wchodze kcc"
6708       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6709       etors=0.0D0
6710       do i=iphi_start,iphi_end
6711 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6712 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6713 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6714 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6715         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6716      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6717         itori=itortyp(itype(i-2))
6718         itori1=itortyp(itype(i-1))
6719         phii=phi(i)
6720         glocig=0.0D0
6721         glocit1=0.0d0
6722         glocit2=0.0d0
6723 C to avoid multiple devision by 2
6724 c        theti22=0.5d0*theta(i)
6725 C theta 12 is the theta_1 /2
6726 C theta 22 is theta_2 /2
6727 c        theti12=0.5d0*theta(i-1)
6728 C and appropriate sinus function
6729         sinthet1=dsin(theta(i-1))
6730         sinthet2=dsin(theta(i))
6731         costhet1=dcos(theta(i-1))
6732         costhet2=dcos(theta(i))
6733 C to speed up lets store its mutliplication
6734         sint1t2=sinthet2*sinthet1
6735         sint1t2n=1.0d0
6736 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6737 C +d_n*sin(n*gamma)) *
6738 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6739 C we have two sum 1) Non-Chebyshev which is with n and gamma
6740         nval=nterm_kcc_Tb(itori,itori1)
6741         c1(0)=0.0d0
6742         c2(0)=0.0d0
6743         c1(1)=1.0d0
6744         c2(1)=1.0d0
6745         do j=2,nval
6746           c1(j)=c1(j-1)*costhet1
6747           c2(j)=c2(j-1)*costhet2
6748         enddo
6749         etori=0.0d0
6750         do j=1,nterm_kcc(itori,itori1)
6751           cosphi=dcos(j*phii)
6752           sinphi=dsin(j*phii)
6753           sint1t2n1=sint1t2n
6754           sint1t2n=sint1t2n*sint1t2
6755           sumvalc=0.0d0
6756           gradvalct1=0.0d0
6757           gradvalct2=0.0d0
6758           do k=1,nval
6759             do l=1,nval
6760               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6761               gradvalct1=gradvalct1+
6762      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6763               gradvalct2=gradvalct2+
6764      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6765             enddo
6766           enddo
6767           gradvalct1=-gradvalct1*sinthet1
6768           gradvalct2=-gradvalct2*sinthet2
6769           sumvals=0.0d0
6770           gradvalst1=0.0d0
6771           gradvalst2=0.0d0
6772           do k=1,nval
6773             do l=1,nval
6774               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6775               gradvalst1=gradvalst1+
6776      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6777               gradvalst2=gradvalst2+
6778      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6779             enddo
6780           enddo
6781           gradvalst1=-gradvalst1*sinthet1
6782           gradvalst2=-gradvalst2*sinthet2
6783           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6784 C glocig is the gradient local i site in gamma
6785           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6786 C now gradient over theta_1
6787           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6788      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6789           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6790      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6791         enddo ! j
6792         etors=etors+etori
6793 C derivative over gamma
6794         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6795 C derivative over theta1
6796         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6797 C now derivative over theta2
6798         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6799         if (lprn) then
6800           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6801      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6802           write (iout,*) "c1",(c1(k),k=0,nval),
6803      &    " c2",(c2(k),k=0,nval)
6804           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6805         endif
6806       enddo
6807       return
6808       end
6809 c---------------------------------------------------------------------------------------------
6810       subroutine etor_constr(edihcnstr)
6811       implicit real*8 (a-h,o-z)
6812       include 'DIMENSIONS'
6813       include 'DIMENSIONS.ZSCOPT'
6814       include 'COMMON.VAR'
6815       include 'COMMON.GEO'
6816       include 'COMMON.LOCAL'
6817       include 'COMMON.TORSION'
6818       include 'COMMON.INTERACT'
6819       include 'COMMON.DERIV'
6820       include 'COMMON.CHAIN'
6821       include 'COMMON.NAMES'
6822       include 'COMMON.IOUNITS'
6823       include 'COMMON.FFIELD'
6824       include 'COMMON.TORCNSTR'
6825       include 'COMMON.CONTROL'
6826 ! 6/20/98 - dihedral angle constraints
6827       edihcnstr=0.0d0
6828 c      do i=1,ndih_constr
6829 c      write (iout,*) "idihconstr_start",idihconstr_start,
6830 c     &  " idihconstr_end",idihconstr_end
6831
6832       if (raw_psipred) then
6833         do i=idihconstr_start,idihconstr_end
6834           itori=idih_constr(i)
6835           phii=phi(itori)
6836           gaudih_i=vpsipred(1,i)
6837           gauder_i=0.0d0
6838           do j=1,2
6839             s = sdihed(j,i)
6840             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6841             dexpcos_i=dexp(-cos_i*cos_i)
6842             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6843             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6844      &            *cos_i*dexpcos_i/s**2
6845           enddo
6846           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6847           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6848           if (energy_dec)
6849      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6850      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6851      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6852      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6853      &     -wdihc*dlog(gaudih_i)
6854         enddo
6855       else
6856
6857       do i=idihconstr_start,idihconstr_end
6858         itori=idih_constr(i)
6859         phii=phi(itori)
6860         difi=pinorm(phii-phi0(i))
6861         if (difi.gt.drange(i)) then
6862           difi=difi-drange(i)
6863           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6864           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6865         else if (difi.lt.-drange(i)) then
6866           difi=difi+drange(i)
6867           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6868           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6869         else
6870           difi=0.0
6871         endif
6872       enddo
6873
6874       endif
6875
6876 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6877       return
6878       end
6879 c----------------------------------------------------------------------------
6880 C The rigorous attempt to derive energy function
6881       subroutine ebend_kcc(etheta)
6882
6883       implicit real*8 (a-h,o-z)
6884       include 'DIMENSIONS'
6885       include 'DIMENSIONS.ZSCOPT'
6886       include 'COMMON.VAR'
6887       include 'COMMON.GEO'
6888       include 'COMMON.LOCAL'
6889       include 'COMMON.TORSION'
6890       include 'COMMON.INTERACT'
6891       include 'COMMON.DERIV'
6892       include 'COMMON.CHAIN'
6893       include 'COMMON.NAMES'
6894       include 'COMMON.IOUNITS'
6895       include 'COMMON.FFIELD'
6896       include 'COMMON.TORCNSTR'
6897       include 'COMMON.CONTROL'
6898       logical lprn
6899       double precision thybt1(maxang_kcc)
6900 C Set lprn=.true. for debugging
6901       lprn=energy_dec
6902 c     lprn=.true.
6903 C      print *,"wchodze kcc"
6904       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6905       etheta=0.0D0
6906       do i=ithet_start,ithet_end
6907 c        print *,i,itype(i-1),itype(i),itype(i-2)
6908         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6909      &  .or.itype(i).eq.ntyp1) cycle
6910         iti=iabs(itortyp(itype(i-1)))
6911         sinthet=dsin(theta(i))
6912         costhet=dcos(theta(i))
6913         do j=1,nbend_kcc_Tb(iti)
6914           thybt1(j)=v1bend_chyb(j,iti)
6915         enddo
6916         sumth1thyb=v1bend_chyb(0,iti)+
6917      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6918         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6919      &    sumth1thyb
6920         ihelp=nbend_kcc_Tb(iti)-1
6921         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6922         etheta=etheta+sumth1thyb
6923 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6924         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6925       enddo
6926       return
6927       end
6928 c-------------------------------------------------------------------------------------
6929       subroutine etheta_constr(ethetacnstr)
6930
6931       implicit real*8 (a-h,o-z)
6932       include 'DIMENSIONS'
6933       include 'DIMENSIONS.ZSCOPT'
6934       include 'COMMON.VAR'
6935       include 'COMMON.GEO'
6936       include 'COMMON.LOCAL'
6937       include 'COMMON.TORSION'
6938       include 'COMMON.INTERACT'
6939       include 'COMMON.DERIV'
6940       include 'COMMON.CHAIN'
6941       include 'COMMON.NAMES'
6942       include 'COMMON.IOUNITS'
6943       include 'COMMON.FFIELD'
6944       include 'COMMON.TORCNSTR'
6945       include 'COMMON.CONTROL'
6946       ethetacnstr=0.0d0
6947 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6948       do i=ithetaconstr_start,ithetaconstr_end
6949         itheta=itheta_constr(i)
6950         thetiii=theta(itheta)
6951         difi=pinorm(thetiii-theta_constr0(i))
6952         if (difi.gt.theta_drange(i)) then
6953           difi=difi-theta_drange(i)
6954           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6955           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6956      &    +for_thet_constr(i)*difi**3
6957         else if (difi.lt.-drange(i)) then
6958           difi=difi+drange(i)
6959           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6960           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6961      &    +for_thet_constr(i)*difi**3
6962         else
6963           difi=0.0
6964         endif
6965        if (energy_dec) then
6966         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6967      &    i,itheta,rad2deg*thetiii,
6968      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6969      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6970      &    gloc(itheta+nphi-2,icg)
6971         endif
6972       enddo
6973       return
6974       end
6975 c------------------------------------------------------------------------------
6976 c------------------------------------------------------------------------------
6977       subroutine eback_sc_corr(esccor)
6978 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6979 c        conformational states; temporarily implemented as differences
6980 c        between UNRES torsional potentials (dependent on three types of
6981 c        residues) and the torsional potentials dependent on all 20 types
6982 c        of residues computed from AM1 energy surfaces of terminally-blocked
6983 c        amino-acid residues.
6984       implicit real*8 (a-h,o-z)
6985       include 'DIMENSIONS'
6986       include 'DIMENSIONS.ZSCOPT'
6987       include 'COMMON.VAR'
6988       include 'COMMON.GEO'
6989       include 'COMMON.LOCAL'
6990       include 'COMMON.TORSION'
6991       include 'COMMON.SCCOR'
6992       include 'COMMON.INTERACT'
6993       include 'COMMON.DERIV'
6994       include 'COMMON.CHAIN'
6995       include 'COMMON.NAMES'
6996       include 'COMMON.IOUNITS'
6997       include 'COMMON.FFIELD'
6998       include 'COMMON.CONTROL'
6999       logical lprn
7000 C Set lprn=.true. for debugging
7001       lprn=.false.
7002 c      lprn=.true.
7003 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7004       esccor=0.0D0
7005       do i=itau_start,itau_end
7006         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7007         esccor_ii=0.0D0
7008         isccori=isccortyp(itype(i-2))
7009         isccori1=isccortyp(itype(i-1))
7010         phii=phi(i)
7011         do intertyp=1,3 !intertyp
7012 cc Added 09 May 2012 (Adasko)
7013 cc  Intertyp means interaction type of backbone mainchain correlation:
7014 c   1 = SC...Ca...Ca...Ca
7015 c   2 = Ca...Ca...Ca...SC
7016 c   3 = SC...Ca...Ca...SCi
7017         gloci=0.0D0
7018         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7019      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7020      &      (itype(i-1).eq.ntyp1)))
7021      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7022      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7023      &     .or.(itype(i).eq.ntyp1)))
7024      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7025      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7026      &      (itype(i-3).eq.ntyp1)))) cycle
7027         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7028         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7029      & cycle
7030        do j=1,nterm_sccor(isccori,isccori1)
7031           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7032           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7033           cosphi=dcos(j*tauangle(intertyp,i))
7034           sinphi=dsin(j*tauangle(intertyp,i))
7035            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7036            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7037          enddo
7038 C      write (iout,*)"EBACK_SC_COR",esccor,i
7039 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7040 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7041 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7042         if (lprn)
7043      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7044      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7045      &  (v1sccor(j,1,itori,itori1),j=1,6)
7046      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7047 c        gsccor_loc(i-3)=gloci
7048        enddo !intertyp
7049       enddo
7050       return
7051       end
7052 #ifdef FOURBODY
7053 c------------------------------------------------------------------------------
7054       subroutine multibody(ecorr)
7055 C This subroutine calculates multi-body contributions to energy following
7056 C the idea of Skolnick et al. If side chains I and J make a contact and
7057 C at the same time side chains I+1 and J+1 make a contact, an extra
7058 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7059       implicit real*8 (a-h,o-z)
7060       include 'DIMENSIONS'
7061       include 'COMMON.IOUNITS'
7062       include 'COMMON.DERIV'
7063       include 'COMMON.INTERACT'
7064       include 'COMMON.CONTACTS'
7065       include 'COMMON.CONTMAT'
7066       include 'COMMON.CORRMAT'
7067       double precision gx(3),gx1(3)
7068       logical lprn
7069
7070 C Set lprn=.true. for debugging
7071       lprn=.false.
7072
7073       if (lprn) then
7074         write (iout,'(a)') 'Contact function values:'
7075         do i=nnt,nct-2
7076           write (iout,'(i2,20(1x,i2,f10.5))')
7077      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7078         enddo
7079       endif
7080       ecorr=0.0D0
7081       do i=nnt,nct
7082         do j=1,3
7083           gradcorr(j,i)=0.0D0
7084           gradxorr(j,i)=0.0D0
7085         enddo
7086       enddo
7087       do i=nnt,nct-2
7088
7089         DO ISHIFT = 3,4
7090
7091         i1=i+ishift
7092         num_conti=num_cont(i)
7093         num_conti1=num_cont(i1)
7094         do jj=1,num_conti
7095           j=jcont(jj,i)
7096           do kk=1,num_conti1
7097             j1=jcont(kk,i1)
7098             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7099 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7100 cd   &                   ' ishift=',ishift
7101 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7102 C The system gains extra energy.
7103               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7104             endif   ! j1==j+-ishift
7105           enddo     ! kk
7106         enddo       ! jj
7107
7108         ENDDO ! ISHIFT
7109
7110       enddo         ! i
7111       return
7112       end
7113 c------------------------------------------------------------------------------
7114       double precision function esccorr(i,j,k,l,jj,kk)
7115       implicit real*8 (a-h,o-z)
7116       include 'DIMENSIONS'
7117       include 'COMMON.IOUNITS'
7118       include 'COMMON.DERIV'
7119       include 'COMMON.INTERACT'
7120       include 'COMMON.CONTACTS'
7121       include 'COMMON.CONTMAT'
7122       include 'COMMON.CORRMAT'
7123       double precision gx(3),gx1(3)
7124       logical lprn
7125       lprn=.false.
7126       eij=facont(jj,i)
7127       ekl=facont(kk,k)
7128 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7129 C Calculate the multi-body contribution to energy.
7130 C Calculate multi-body contributions to the gradient.
7131 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7132 cd   & k,l,(gacont(m,kk,k),m=1,3)
7133       do m=1,3
7134         gx(m) =ekl*gacont(m,jj,i)
7135         gx1(m)=eij*gacont(m,kk,k)
7136         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7137         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7138         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7139         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7140       enddo
7141       do m=i,j-1
7142         do ll=1,3
7143           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7144         enddo
7145       enddo
7146       do m=k,l-1
7147         do ll=1,3
7148           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7149         enddo
7150       enddo
7151       esccorr=-eij*ekl
7152       return
7153       end
7154 c------------------------------------------------------------------------------
7155       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7156 C This subroutine calculates multi-body contributions to hydrogen-bonding
7157       implicit real*8 (a-h,o-z)
7158       include 'DIMENSIONS'
7159       include 'DIMENSIONS.ZSCOPT'
7160       include 'COMMON.IOUNITS'
7161       include 'COMMON.FFIELD'
7162       include 'COMMON.DERIV'
7163       include 'COMMON.INTERACT'
7164       include 'COMMON.CONTACTS'
7165       include 'COMMON.CONTMAT'
7166       include 'COMMON.CORRMAT'
7167       double precision gx(3),gx1(3)
7168       logical lprn,ldone
7169
7170 C Set lprn=.true. for debugging
7171       lprn=.false.
7172       if (lprn) then
7173         write (iout,'(a)') 'Contact function values:'
7174         do i=nnt,nct-2
7175           write (iout,'(2i3,50(1x,i2,f5.2))')
7176      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7177      &    j=1,num_cont_hb(i))
7178         enddo
7179       endif
7180       ecorr=0.0D0
7181 C Remove the loop below after debugging !!!
7182       do i=nnt,nct
7183         do j=1,3
7184           gradcorr(j,i)=0.0D0
7185           gradxorr(j,i)=0.0D0
7186         enddo
7187       enddo
7188 C Calculate the local-electrostatic correlation terms
7189       do i=iatel_s,iatel_e+1
7190         i1=i+1
7191         num_conti=num_cont_hb(i)
7192         num_conti1=num_cont_hb(i+1)
7193         do jj=1,num_conti
7194           j=jcont_hb(jj,i)
7195           do kk=1,num_conti1
7196             j1=jcont_hb(kk,i1)
7197 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7198 c     &         ' jj=',jj,' kk=',kk
7199             if (j1.eq.j+1 .or. j1.eq.j-1) then
7200 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7201 C The system gains extra energy.
7202               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7203               n_corr=n_corr+1
7204             else if (j1.eq.j) then
7205 C Contacts I-J and I-(J+1) occur simultaneously.
7206 C The system loses extra energy.
7207 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7208             endif
7209           enddo ! kk
7210           do kk=1,num_conti
7211             j1=jcont_hb(kk,i)
7212 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7213 c    &         ' jj=',jj,' kk=',kk
7214             if (j1.eq.j+1) then
7215 C Contacts I-J and (I+1)-J occur simultaneously.
7216 C The system loses extra energy.
7217 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7218             endif ! j1==j+1
7219           enddo ! kk
7220         enddo ! jj
7221       enddo ! i
7222       return
7223       end
7224 c------------------------------------------------------------------------------
7225       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7226      &  n_corr1)
7227 C This subroutine calculates multi-body contributions to hydrogen-bonding
7228       implicit real*8 (a-h,o-z)
7229       include 'DIMENSIONS'
7230       include 'DIMENSIONS.ZSCOPT'
7231       include 'COMMON.IOUNITS'
7232 #ifdef MPI
7233       include "mpif.h"
7234 #endif
7235       include 'COMMON.FFIELD'
7236       include 'COMMON.DERIV'
7237       include 'COMMON.LOCAL'
7238       include 'COMMON.INTERACT'
7239       include 'COMMON.CONTACTS'
7240       include 'COMMON.CONTMAT'
7241       include 'COMMON.CORRMAT'
7242       include 'COMMON.CHAIN'
7243       include 'COMMON.CONTROL'
7244       include 'COMMON.SHIELD'
7245       double precision gx(3),gx1(3)
7246       integer num_cont_hb_old(maxres)
7247       logical lprn,ldone
7248       double precision eello4,eello5,eelo6,eello_turn6
7249       external eello4,eello5,eello6,eello_turn6
7250 C Set lprn=.true. for debugging
7251       lprn=.false.
7252       eturn6=0.0d0
7253       if (lprn) then
7254         write (iout,'(a)') 'Contact function values:'
7255         do i=nnt,nct-2
7256           write (iout,'(2i3,50(1x,i2,5f6.3))')
7257      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7258      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7259         enddo
7260       endif
7261       ecorr=0.0D0
7262       ecorr5=0.0d0
7263       ecorr6=0.0d0
7264 C Remove the loop below after debugging !!!
7265       do i=nnt,nct
7266         do j=1,3
7267           gradcorr(j,i)=0.0D0
7268           gradxorr(j,i)=0.0D0
7269         enddo
7270       enddo
7271 C Calculate the dipole-dipole interaction energies
7272       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7273       do i=iatel_s,iatel_e+1
7274         num_conti=num_cont_hb(i)
7275         do jj=1,num_conti
7276           j=jcont_hb(jj,i)
7277 #ifdef MOMENT
7278           call dipole(i,j,jj)
7279 #endif
7280         enddo
7281       enddo
7282       endif
7283 C Calculate the local-electrostatic correlation terms
7284 c                write (iout,*) "gradcorr5 in eello5 before loop"
7285 c                do iii=1,nres
7286 c                  write (iout,'(i5,3f10.5)')
7287 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7288 c                enddo
7289       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7290 c        write (iout,*) "corr loop i",i
7291         i1=i+1
7292         num_conti=num_cont_hb(i)
7293         num_conti1=num_cont_hb(i+1)
7294         do jj=1,num_conti
7295           j=jcont_hb(jj,i)
7296           jp=iabs(j)
7297           do kk=1,num_conti1
7298             j1=jcont_hb(kk,i1)
7299             jp1=iabs(j1)
7300 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7301 c     &         ' jj=',jj,' kk=',kk
7302 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7303             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7304      &          .or. j.lt.0 .and. j1.gt.0) .and.
7305      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7306 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7307 C The system gains extra energy.
7308               n_corr=n_corr+1
7309               sqd1=dsqrt(d_cont(jj,i))
7310               sqd2=dsqrt(d_cont(kk,i1))
7311               sred_geom = sqd1*sqd2
7312               IF (sred_geom.lt.cutoff_corr) THEN
7313                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7314      &            ekont,fprimcont)
7315 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7316 cd     &         ' jj=',jj,' kk=',kk
7317                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7318                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7319                 do l=1,3
7320                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7321                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7322                 enddo
7323                 n_corr1=n_corr1+1
7324 cd               write (iout,*) 'sred_geom=',sred_geom,
7325 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7326 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7327 cd               write (iout,*) "g_contij",g_contij
7328 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7329 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7330                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7331                 if (wcorr4.gt.0.0d0)
7332      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7333 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7334                   if (energy_dec.and.wcorr4.gt.0.0d0)
7335      1                 write (iout,'(a6,4i5,0pf7.3)')
7336      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7337 c                write (iout,*) "gradcorr5 before eello5"
7338 c                do iii=1,nres
7339 c                  write (iout,'(i5,3f10.5)')
7340 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7341 c                enddo
7342                 if (wcorr5.gt.0.0d0)
7343      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7344 c                write (iout,*) "gradcorr5 after eello5"
7345 c                do iii=1,nres
7346 c                  write (iout,'(i5,3f10.5)')
7347 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7348 c                enddo
7349                   if (energy_dec.and.wcorr5.gt.0.0d0)
7350      1                 write (iout,'(a6,4i5,0pf7.3)')
7351      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7352 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7353 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7354                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7355      &               .or. wturn6.eq.0.0d0))then
7356 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7357                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7358                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7359      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7360 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7361 cd     &            'ecorr6=',ecorr6
7362 cd                write (iout,'(4e15.5)') sred_geom,
7363 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7364 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7365 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7366                 else if (wturn6.gt.0.0d0
7367      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7368 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7369                   eturn6=eturn6+eello_turn6(i,jj,kk)
7370                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7371      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7372 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7373                 endif
7374               ENDIF
7375 1111          continue
7376             endif
7377           enddo ! kk
7378         enddo ! jj
7379       enddo ! i
7380       do i=1,nres
7381         num_cont_hb(i)=num_cont_hb_old(i)
7382       enddo
7383 c                write (iout,*) "gradcorr5 in eello5"
7384 c                do iii=1,nres
7385 c                  write (iout,'(i5,3f10.5)')
7386 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7387 c                enddo
7388       return
7389       end
7390 c------------------------------------------------------------------------------
7391       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7392       implicit real*8 (a-h,o-z)
7393       include 'DIMENSIONS'
7394       include 'DIMENSIONS.ZSCOPT'
7395       include 'COMMON.IOUNITS'
7396       include 'COMMON.DERIV'
7397       include 'COMMON.INTERACT'
7398       include 'COMMON.CONTACTS'
7399       include 'COMMON.CONTMAT'
7400       include 'COMMON.CORRMAT'
7401       include 'COMMON.SHIELD'
7402       include 'COMMON.CONTROL'
7403       double precision gx(3),gx1(3)
7404       logical lprn
7405       lprn=.false.
7406 C      print *,"wchodze",fac_shield(i),shield_mode
7407       eij=facont_hb(jj,i)
7408       ekl=facont_hb(kk,k)
7409       ees0pij=ees0p(jj,i)
7410       ees0pkl=ees0p(kk,k)
7411       ees0mij=ees0m(jj,i)
7412       ees0mkl=ees0m(kk,k)
7413       ekont=eij*ekl
7414       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7415 C*
7416 C     & fac_shield(i)**2*fac_shield(j)**2
7417 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7418 C Following 4 lines for diagnostics.
7419 cd    ees0pkl=0.0D0
7420 cd    ees0pij=1.0D0
7421 cd    ees0mkl=0.0D0
7422 cd    ees0mij=1.0D0
7423 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7424 c     & 'Contacts ',i,j,
7425 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7426 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7427 c     & 'gradcorr_long'
7428 C Calculate the multi-body contribution to energy.
7429 C      ecorr=ecorr+ekont*ees
7430 C Calculate multi-body contributions to the gradient.
7431       coeffpees0pij=coeffp*ees0pij
7432       coeffmees0mij=coeffm*ees0mij
7433       coeffpees0pkl=coeffp*ees0pkl
7434       coeffmees0mkl=coeffm*ees0mkl
7435       do ll=1,3
7436 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7437         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7438      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7439      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7440         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7441      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7442      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7443 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7444         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7445      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7446      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7447         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7448      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7449      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7450         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7451      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7452      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7453         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7454         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7455         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7456      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7457      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7458         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7459         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7460 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7461       enddo
7462 c      write (iout,*)
7463 cgrad      do m=i+1,j-1
7464 cgrad        do ll=1,3
7465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7466 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7467 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7468 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7469 cgrad        enddo
7470 cgrad      enddo
7471 cgrad      do m=k+1,l-1
7472 cgrad        do ll=1,3
7473 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7474 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7475 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7476 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7477 cgrad        enddo
7478 cgrad      enddo
7479 c      write (iout,*) "ehbcorr",ekont*ees
7480 C      print *,ekont,ees,i,k
7481       ehbcorr=ekont*ees
7482 C now gradient over shielding
7483 C      return
7484       if (shield_mode.gt.0) then
7485        j=ees0plist(jj,i)
7486        l=ees0plist(kk,k)
7487 C        print *,i,j,fac_shield(i),fac_shield(j),
7488 C     &fac_shield(k),fac_shield(l)
7489         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7490      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7491           do ilist=1,ishield_list(i)
7492            iresshield=shield_list(ilist,i)
7493            do m=1,3
7494            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7495 C     &      *2.0
7496            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7497      &              rlocshield
7498      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7499             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7500      &+rlocshield
7501            enddo
7502           enddo
7503           do ilist=1,ishield_list(j)
7504            iresshield=shield_list(ilist,j)
7505            do m=1,3
7506            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7507 C     &     *2.0
7508            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7509      &              rlocshield
7510      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7511            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7512      &     +rlocshield
7513            enddo
7514           enddo
7515
7516           do ilist=1,ishield_list(k)
7517            iresshield=shield_list(ilist,k)
7518            do m=1,3
7519            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7520 C     &     *2.0
7521            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7522      &              rlocshield
7523      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7524            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7525      &     +rlocshield
7526            enddo
7527           enddo
7528           do ilist=1,ishield_list(l)
7529            iresshield=shield_list(ilist,l)
7530            do m=1,3
7531            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7532 C     &     *2.0
7533            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7534      &              rlocshield
7535      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7536            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7537      &     +rlocshield
7538            enddo
7539           enddo
7540 C          print *,gshieldx(m,iresshield)
7541           do m=1,3
7542             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7543      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7544             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7545      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7546             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7547      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7548             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7549      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7550
7551             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7552      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7553             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7554      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7555             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7556      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7557             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7558      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7559
7560            enddo
7561       endif
7562       endif
7563       return
7564       end
7565 #ifdef MOMENT
7566 C---------------------------------------------------------------------------
7567       subroutine dipole(i,j,jj)
7568       implicit real*8 (a-h,o-z)
7569       include 'DIMENSIONS'
7570       include 'DIMENSIONS.ZSCOPT'
7571       include 'COMMON.IOUNITS'
7572       include 'COMMON.CHAIN'
7573       include 'COMMON.FFIELD'
7574       include 'COMMON.DERIV'
7575       include 'COMMON.INTERACT'
7576       include 'COMMON.CONTACTS'
7577       include 'COMMON.CONTMAT'
7578       include 'COMMON.CORRMAT'
7579       include 'COMMON.TORSION'
7580       include 'COMMON.VAR'
7581       include 'COMMON.GEO'
7582       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7583      &  auxmat(2,2)
7584       iti1 = itortyp(itype(i+1))
7585       if (j.lt.nres-1) then
7586         itj1 = itype2loc(itype(j+1))
7587       else
7588         itj1=nloctyp
7589       endif
7590       do iii=1,2
7591         dipi(iii,1)=Ub2(iii,i)
7592         dipderi(iii)=Ub2der(iii,i)
7593         dipi(iii,2)=b1(iii,i+1)
7594         dipj(iii,1)=Ub2(iii,j)
7595         dipderj(iii)=Ub2der(iii,j)
7596         dipj(iii,2)=b1(iii,j+1)
7597       enddo
7598       kkk=0
7599       do iii=1,2
7600         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7601         do jjj=1,2
7602           kkk=kkk+1
7603           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7604         enddo
7605       enddo
7606       do kkk=1,5
7607         do lll=1,3
7608           mmm=0
7609           do iii=1,2
7610             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7611      &        auxvec(1))
7612             do jjj=1,2
7613               mmm=mmm+1
7614               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7615             enddo
7616           enddo
7617         enddo
7618       enddo
7619       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7620       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7621       do iii=1,2
7622         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7623       enddo
7624       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7625       do iii=1,2
7626         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7627       enddo
7628       return
7629       end
7630 #endif
7631 C---------------------------------------------------------------------------
7632       subroutine calc_eello(i,j,k,l,jj,kk)
7633 C
7634 C This subroutine computes matrices and vectors needed to calculate
7635 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7636 C
7637       implicit real*8 (a-h,o-z)
7638       include 'DIMENSIONS'
7639       include 'DIMENSIONS.ZSCOPT'
7640       include 'COMMON.IOUNITS'
7641       include 'COMMON.CHAIN'
7642       include 'COMMON.DERIV'
7643       include 'COMMON.INTERACT'
7644       include 'COMMON.CONTACTS'
7645       include 'COMMON.CONTMAT'
7646       include 'COMMON.CORRMAT'
7647       include 'COMMON.TORSION'
7648       include 'COMMON.VAR'
7649       include 'COMMON.GEO'
7650       include 'COMMON.FFIELD'
7651       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7652      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7653       logical lprn
7654       common /kutas/ lprn
7655 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7656 cd     & ' jj=',jj,' kk=',kk
7657 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7658 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7659 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7660       do iii=1,2
7661         do jjj=1,2
7662           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7663           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7664         enddo
7665       enddo
7666       call transpose2(aa1(1,1),aa1t(1,1))
7667       call transpose2(aa2(1,1),aa2t(1,1))
7668       do kkk=1,5
7669         do lll=1,3
7670           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7671      &      aa1tder(1,1,lll,kkk))
7672           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7673      &      aa2tder(1,1,lll,kkk))
7674         enddo
7675       enddo
7676       if (l.eq.j+1) then
7677 C parallel orientation of the two CA-CA-CA frames.
7678         if (i.gt.1) then
7679           iti=itype2loc(itype(i))
7680         else
7681           iti=nloctyp
7682         endif
7683         itk1=itype2loc(itype(k+1))
7684         itj=itype2loc(itype(j))
7685         if (l.lt.nres-1) then
7686           itl1=itype2loc(itype(l+1))
7687         else
7688           itl1=nloctyp
7689         endif
7690 C A1 kernel(j+1) A2T
7691 cd        do iii=1,2
7692 cd          write (iout,'(3f10.5,5x,3f10.5)')
7693 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7694 cd        enddo
7695         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7696      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7697      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7698 C Following matrices are needed only for 6-th order cumulants
7699         IF (wcorr6.gt.0.0d0) THEN
7700         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7701      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7702      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7703         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7704      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7705      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7706      &   ADtEAderx(1,1,1,1,1,1))
7707         lprn=.false.
7708         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7709      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7710      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7711      &   ADtEA1derx(1,1,1,1,1,1))
7712         ENDIF
7713 C End 6-th order cumulants
7714 cd        lprn=.false.
7715 cd        if (lprn) then
7716 cd        write (2,*) 'In calc_eello6'
7717 cd        do iii=1,2
7718 cd          write (2,*) 'iii=',iii
7719 cd          do kkk=1,5
7720 cd            write (2,*) 'kkk=',kkk
7721 cd            do jjj=1,2
7722 cd              write (2,'(3(2f10.5),5x)')
7723 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7724 cd            enddo
7725 cd          enddo
7726 cd        enddo
7727 cd        endif
7728         call transpose2(EUgder(1,1,k),auxmat(1,1))
7729         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7730         call transpose2(EUg(1,1,k),auxmat(1,1))
7731         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7732         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7733         do iii=1,2
7734           do kkk=1,5
7735             do lll=1,3
7736               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7737      &          EAEAderx(1,1,lll,kkk,iii,1))
7738             enddo
7739           enddo
7740         enddo
7741 C A1T kernel(i+1) A2
7742         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7743      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7744      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7745 C Following matrices are needed only for 6-th order cumulants
7746         IF (wcorr6.gt.0.0d0) THEN
7747         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7748      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7749      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7750         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7751      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7752      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7753      &   ADtEAderx(1,1,1,1,1,2))
7754         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7755      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7756      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7757      &   ADtEA1derx(1,1,1,1,1,2))
7758         ENDIF
7759 C End 6-th order cumulants
7760         call transpose2(EUgder(1,1,l),auxmat(1,1))
7761         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7762         call transpose2(EUg(1,1,l),auxmat(1,1))
7763         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7764         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7765         do iii=1,2
7766           do kkk=1,5
7767             do lll=1,3
7768               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7769      &          EAEAderx(1,1,lll,kkk,iii,2))
7770             enddo
7771           enddo
7772         enddo
7773 C AEAb1 and AEAb2
7774 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7775 C They are needed only when the fifth- or the sixth-order cumulants are
7776 C indluded.
7777         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7778         call transpose2(AEA(1,1,1),auxmat(1,1))
7779         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7780         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7781         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7782         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7783         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7784         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7785         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7786         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7787         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7788         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7789         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7790         call transpose2(AEA(1,1,2),auxmat(1,1))
7791         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7792         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7793         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7794         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7795         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7796         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7797         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7798         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7799         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7800         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7801         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7802 C Calculate the Cartesian derivatives of the vectors.
7803         do iii=1,2
7804           do kkk=1,5
7805             do lll=1,3
7806               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7807               call matvec2(auxmat(1,1),b1(1,i),
7808      &          AEAb1derx(1,lll,kkk,iii,1,1))
7809               call matvec2(auxmat(1,1),Ub2(1,i),
7810      &          AEAb2derx(1,lll,kkk,iii,1,1))
7811               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7812      &          AEAb1derx(1,lll,kkk,iii,2,1))
7813               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7814      &          AEAb2derx(1,lll,kkk,iii,2,1))
7815               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7816               call matvec2(auxmat(1,1),b1(1,j),
7817      &          AEAb1derx(1,lll,kkk,iii,1,2))
7818               call matvec2(auxmat(1,1),Ub2(1,j),
7819      &          AEAb2derx(1,lll,kkk,iii,1,2))
7820               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7821      &          AEAb1derx(1,lll,kkk,iii,2,2))
7822               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7823      &          AEAb2derx(1,lll,kkk,iii,2,2))
7824             enddo
7825           enddo
7826         enddo
7827         ENDIF
7828 C End vectors
7829       else
7830 C Antiparallel orientation of the two CA-CA-CA frames.
7831         if (i.gt.1) then
7832           iti=itype2loc(itype(i))
7833         else
7834           iti=nloctyp
7835         endif
7836         itk1=itype2loc(itype(k+1))
7837         itl=itype2loc(itype(l))
7838         itj=itype2loc(itype(j))
7839         if (j.lt.nres-1) then
7840           itj1=itype2loc(itype(j+1))
7841         else
7842           itj1=nloctyp
7843         endif
7844 C A2 kernel(j-1)T A1T
7845         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7846      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7847      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7848 C Following matrices are needed only for 6-th order cumulants
7849         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7850      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7851         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7852      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7853      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7854         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7855      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7856      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7857      &   ADtEAderx(1,1,1,1,1,1))
7858         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7859      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7860      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7861      &   ADtEA1derx(1,1,1,1,1,1))
7862         ENDIF
7863 C End 6-th order cumulants
7864         call transpose2(EUgder(1,1,k),auxmat(1,1))
7865         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7866         call transpose2(EUg(1,1,k),auxmat(1,1))
7867         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7868         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7869         do iii=1,2
7870           do kkk=1,5
7871             do lll=1,3
7872               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7873      &          EAEAderx(1,1,lll,kkk,iii,1))
7874             enddo
7875           enddo
7876         enddo
7877 C A2T kernel(i+1)T A1
7878         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7879      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7880      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7881 C Following matrices are needed only for 6-th order cumulants
7882         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7883      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7884         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7885      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7886      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7887         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7888      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7889      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7890      &   ADtEAderx(1,1,1,1,1,2))
7891         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7892      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7893      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7894      &   ADtEA1derx(1,1,1,1,1,2))
7895         ENDIF
7896 C End 6-th order cumulants
7897         call transpose2(EUgder(1,1,j),auxmat(1,1))
7898         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7899         call transpose2(EUg(1,1,j),auxmat(1,1))
7900         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7901         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7902         do iii=1,2
7903           do kkk=1,5
7904             do lll=1,3
7905               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7906      &          EAEAderx(1,1,lll,kkk,iii,2))
7907             enddo
7908           enddo
7909         enddo
7910 C AEAb1 and AEAb2
7911 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7912 C They are needed only when the fifth- or the sixth-order cumulants are
7913 C indluded.
7914         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7915      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7916         call transpose2(AEA(1,1,1),auxmat(1,1))
7917         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7918         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7919         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7920         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7921         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7922         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7923         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7924         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7925         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7926         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7927         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7928         call transpose2(AEA(1,1,2),auxmat(1,1))
7929         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7930         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7931         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7932         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7933         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7934         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7935         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7936         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7937         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7938         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7939         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7940 C Calculate the Cartesian derivatives of the vectors.
7941         do iii=1,2
7942           do kkk=1,5
7943             do lll=1,3
7944               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7945               call matvec2(auxmat(1,1),b1(1,i),
7946      &          AEAb1derx(1,lll,kkk,iii,1,1))
7947               call matvec2(auxmat(1,1),Ub2(1,i),
7948      &          AEAb2derx(1,lll,kkk,iii,1,1))
7949               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7950      &          AEAb1derx(1,lll,kkk,iii,2,1))
7951               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7952      &          AEAb2derx(1,lll,kkk,iii,2,1))
7953               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7954               call matvec2(auxmat(1,1),b1(1,l),
7955      &          AEAb1derx(1,lll,kkk,iii,1,2))
7956               call matvec2(auxmat(1,1),Ub2(1,l),
7957      &          AEAb2derx(1,lll,kkk,iii,1,2))
7958               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7959      &          AEAb1derx(1,lll,kkk,iii,2,2))
7960               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7961      &          AEAb2derx(1,lll,kkk,iii,2,2))
7962             enddo
7963           enddo
7964         enddo
7965         ENDIF
7966 C End vectors
7967       endif
7968       return
7969       end
7970 C---------------------------------------------------------------------------
7971       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7972      &  KK,KKderg,AKA,AKAderg,AKAderx)
7973       implicit none
7974       integer nderg
7975       logical transp
7976       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7977      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7978      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7979       integer iii,kkk,lll
7980       integer jjj,mmm
7981       logical lprn
7982       common /kutas/ lprn
7983       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7984       do iii=1,nderg
7985         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7986      &    AKAderg(1,1,iii))
7987       enddo
7988 cd      if (lprn) write (2,*) 'In kernel'
7989       do kkk=1,5
7990 cd        if (lprn) write (2,*) 'kkk=',kkk
7991         do lll=1,3
7992           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7993      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7994 cd          if (lprn) then
7995 cd            write (2,*) 'lll=',lll
7996 cd            write (2,*) 'iii=1'
7997 cd            do jjj=1,2
7998 cd              write (2,'(3(2f10.5),5x)')
7999 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8000 cd            enddo
8001 cd          endif
8002           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8003      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8004 cd          if (lprn) then
8005 cd            write (2,*) 'lll=',lll
8006 cd            write (2,*) 'iii=2'
8007 cd            do jjj=1,2
8008 cd              write (2,'(3(2f10.5),5x)')
8009 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8010 cd            enddo
8011 cd          endif
8012         enddo
8013       enddo
8014       return
8015       end
8016 C---------------------------------------------------------------------------
8017       double precision function eello4(i,j,k,l,jj,kk)
8018       implicit real*8 (a-h,o-z)
8019       include 'DIMENSIONS'
8020       include 'DIMENSIONS.ZSCOPT'
8021       include 'COMMON.IOUNITS'
8022       include 'COMMON.CHAIN'
8023       include 'COMMON.DERIV'
8024       include 'COMMON.INTERACT'
8025       include 'COMMON.CONTACTS'
8026       include 'COMMON.CONTMAT'
8027       include 'COMMON.CORRMAT'
8028       include 'COMMON.TORSION'
8029       include 'COMMON.VAR'
8030       include 'COMMON.GEO'
8031       double precision pizda(2,2),ggg1(3),ggg2(3)
8032 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8033 cd        eello4=0.0d0
8034 cd        return
8035 cd      endif
8036 cd      print *,'eello4:',i,j,k,l,jj,kk
8037 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8038 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8039 cold      eij=facont_hb(jj,i)
8040 cold      ekl=facont_hb(kk,k)
8041 cold      ekont=eij*ekl
8042       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8043       if (calc_grad) then
8044 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8045       gcorr_loc(k-1)=gcorr_loc(k-1)
8046      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8047       if (l.eq.j+1) then
8048         gcorr_loc(l-1)=gcorr_loc(l-1)
8049      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8050       else
8051         gcorr_loc(j-1)=gcorr_loc(j-1)
8052      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8053       endif
8054       do iii=1,2
8055         do kkk=1,5
8056           do lll=1,3
8057             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8058      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8059 cd            derx(lll,kkk,iii)=0.0d0
8060           enddo
8061         enddo
8062       enddo
8063 cd      gcorr_loc(l-1)=0.0d0
8064 cd      gcorr_loc(j-1)=0.0d0
8065 cd      gcorr_loc(k-1)=0.0d0
8066 cd      eel4=1.0d0
8067 cd      write (iout,*)'Contacts have occurred for peptide groups',
8068 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8069 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8070       if (j.lt.nres-1) then
8071         j1=j+1
8072         j2=j-1
8073       else
8074         j1=j-1
8075         j2=j-2
8076       endif
8077       if (l.lt.nres-1) then
8078         l1=l+1
8079         l2=l-1
8080       else
8081         l1=l-1
8082         l2=l-2
8083       endif
8084       do ll=1,3
8085 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8086 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8087         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8088         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8089 cgrad        ghalf=0.5d0*ggg1(ll)
8090         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8091         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8092         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8093         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8094         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8095         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8096 cgrad        ghalf=0.5d0*ggg2(ll)
8097         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8098         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8099         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8100         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8101         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8102         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8103       enddo
8104 cgrad      do m=i+1,j-1
8105 cgrad        do ll=1,3
8106 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8107 cgrad        enddo
8108 cgrad      enddo
8109 cgrad      do m=k+1,l-1
8110 cgrad        do ll=1,3
8111 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8112 cgrad        enddo
8113 cgrad      enddo
8114 cgrad      do m=i+2,j2
8115 cgrad        do ll=1,3
8116 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8117 cgrad        enddo
8118 cgrad      enddo
8119 cgrad      do m=k+2,l2
8120 cgrad        do ll=1,3
8121 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8122 cgrad        enddo
8123 cgrad      enddo
8124 cd      do iii=1,nres-3
8125 cd        write (2,*) iii,gcorr_loc(iii)
8126 cd      enddo
8127       endif ! calc_grad
8128       eello4=ekont*eel4
8129 cd      write (2,*) 'ekont',ekont
8130 cd      write (iout,*) 'eello4',ekont*eel4
8131       return
8132       end
8133 C---------------------------------------------------------------------------
8134       double precision function eello5(i,j,k,l,jj,kk)
8135       implicit real*8 (a-h,o-z)
8136       include 'DIMENSIONS'
8137       include 'DIMENSIONS.ZSCOPT'
8138       include 'COMMON.IOUNITS'
8139       include 'COMMON.CHAIN'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       include 'COMMON.CONTMAT'
8144       include 'COMMON.CORRMAT'
8145       include 'COMMON.TORSION'
8146       include 'COMMON.VAR'
8147       include 'COMMON.GEO'
8148       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8149       double precision ggg1(3),ggg2(3)
8150 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8151 C                                                                              C
8152 C                            Parallel chains                                   C
8153 C                                                                              C
8154 C          o             o                   o             o                   C
8155 C         /l\           / \             \   / \           / \   /              C
8156 C        /   \         /   \             \ /   \         /   \ /               C
8157 C       j| o |l1       | o |              o| o |         | o |o                C
8158 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8159 C      \i/   \         /   \ /             /   \         /   \                 C
8160 C       o    k1             o                                                  C
8161 C         (I)          (II)                (III)          (IV)                 C
8162 C                                                                              C
8163 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8164 C                                                                              C
8165 C                            Antiparallel chains                               C
8166 C                                                                              C
8167 C          o             o                   o             o                   C
8168 C         /j\           / \             \   / \           / \   /              C
8169 C        /   \         /   \             \ /   \         /   \ /               C
8170 C      j1| o |l        | o |              o| o |         | o |o                C
8171 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8172 C      \i/   \         /   \ /             /   \         /   \                 C
8173 C       o     k1            o                                                  C
8174 C         (I)          (II)                (III)          (IV)                 C
8175 C                                                                              C
8176 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8177 C                                                                              C
8178 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8179 C                                                                              C
8180 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8181 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8182 cd        eello5=0.0d0
8183 cd        return
8184 cd      endif
8185 cd      write (iout,*)
8186 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8187 cd     &   ' and',k,l
8188       itk=itype2loc(itype(k))
8189       itl=itype2loc(itype(l))
8190       itj=itype2loc(itype(j))
8191       eello5_1=0.0d0
8192       eello5_2=0.0d0
8193       eello5_3=0.0d0
8194       eello5_4=0.0d0
8195 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8196 cd     &   eel5_3_num,eel5_4_num)
8197       do iii=1,2
8198         do kkk=1,5
8199           do lll=1,3
8200             derx(lll,kkk,iii)=0.0d0
8201           enddo
8202         enddo
8203       enddo
8204 cd      eij=facont_hb(jj,i)
8205 cd      ekl=facont_hb(kk,k)
8206 cd      ekont=eij*ekl
8207 cd      write (iout,*)'Contacts have occurred for peptide groups',
8208 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8209 cd      goto 1111
8210 C Contribution from the graph I.
8211 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8212 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8213       call transpose2(EUg(1,1,k),auxmat(1,1))
8214       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8215       vv(1)=pizda(1,1)-pizda(2,2)
8216       vv(2)=pizda(1,2)+pizda(2,1)
8217       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8218      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8219       if (calc_grad) then
8220 C Explicit gradient in virtual-dihedral angles.
8221       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8222      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8223      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8224       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8225       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8226       vv(1)=pizda(1,1)-pizda(2,2)
8227       vv(2)=pizda(1,2)+pizda(2,1)
8228       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8229      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8230      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8231       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8232       vv(1)=pizda(1,1)-pizda(2,2)
8233       vv(2)=pizda(1,2)+pizda(2,1)
8234       if (l.eq.j+1) then
8235         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8236      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8237      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8238       else
8239         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8240      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8241      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8242       endif
8243 C Cartesian gradient
8244       do iii=1,2
8245         do kkk=1,5
8246           do lll=1,3
8247             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8248      &        pizda(1,1))
8249             vv(1)=pizda(1,1)-pizda(2,2)
8250             vv(2)=pizda(1,2)+pizda(2,1)
8251             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8252      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8253      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8254           enddo
8255         enddo
8256       enddo
8257       endif ! calc_grad
8258 c      goto 1112
8259 c1111  continue
8260 C Contribution from graph II
8261       call transpose2(EE(1,1,k),auxmat(1,1))
8262       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8263       vv(1)=pizda(1,1)+pizda(2,2)
8264       vv(2)=pizda(2,1)-pizda(1,2)
8265       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8266      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8267       if (calc_grad) then
8268 C Explicit gradient in virtual-dihedral angles.
8269       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8270      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8271       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8272       vv(1)=pizda(1,1)+pizda(2,2)
8273       vv(2)=pizda(2,1)-pizda(1,2)
8274       if (l.eq.j+1) then
8275         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8276      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8277      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8278       else
8279         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8280      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8281      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8282       endif
8283 C Cartesian gradient
8284       do iii=1,2
8285         do kkk=1,5
8286           do lll=1,3
8287             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8288      &        pizda(1,1))
8289             vv(1)=pizda(1,1)+pizda(2,2)
8290             vv(2)=pizda(2,1)-pizda(1,2)
8291             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8292      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8293      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8294           enddo
8295         enddo
8296       enddo
8297       endif ! calc_grad
8298 cd      goto 1112
8299 cd1111  continue
8300       if (l.eq.j+1) then
8301 cd        goto 1110
8302 C Parallel orientation
8303 C Contribution from graph III
8304         call transpose2(EUg(1,1,l),auxmat(1,1))
8305         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8306         vv(1)=pizda(1,1)-pizda(2,2)
8307         vv(2)=pizda(1,2)+pizda(2,1)
8308         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8309      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8310         if (calc_grad) then
8311 C Explicit gradient in virtual-dihedral angles.
8312         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8313      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8314      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8315         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8316         vv(1)=pizda(1,1)-pizda(2,2)
8317         vv(2)=pizda(1,2)+pizda(2,1)
8318         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8319      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8320      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8321         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8322         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8323         vv(1)=pizda(1,1)-pizda(2,2)
8324         vv(2)=pizda(1,2)+pizda(2,1)
8325         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8326      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8327      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8328 C Cartesian gradient
8329         do iii=1,2
8330           do kkk=1,5
8331             do lll=1,3
8332               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8333      &          pizda(1,1))
8334               vv(1)=pizda(1,1)-pizda(2,2)
8335               vv(2)=pizda(1,2)+pizda(2,1)
8336               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8337      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8338      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8339             enddo
8340           enddo
8341         enddo
8342 cd        goto 1112
8343 C Contribution from graph IV
8344 cd1110    continue
8345         call transpose2(EE(1,1,l),auxmat(1,1))
8346         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8347         vv(1)=pizda(1,1)+pizda(2,2)
8348         vv(2)=pizda(2,1)-pizda(1,2)
8349         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8350      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8351 C Explicit gradient in virtual-dihedral angles.
8352         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8353      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8354         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8355         vv(1)=pizda(1,1)+pizda(2,2)
8356         vv(2)=pizda(2,1)-pizda(1,2)
8357         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8358      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8359      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8360 C Cartesian gradient
8361         do iii=1,2
8362           do kkk=1,5
8363             do lll=1,3
8364               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8365      &          pizda(1,1))
8366               vv(1)=pizda(1,1)+pizda(2,2)
8367               vv(2)=pizda(2,1)-pizda(1,2)
8368               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8369      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8370      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8371             enddo
8372           enddo
8373         enddo
8374         endif ! calc_grad
8375       else
8376 C Antiparallel orientation
8377 C Contribution from graph III
8378 c        goto 1110
8379         call transpose2(EUg(1,1,j),auxmat(1,1))
8380         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8381         vv(1)=pizda(1,1)-pizda(2,2)
8382         vv(2)=pizda(1,2)+pizda(2,1)
8383         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8384      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8385         if (calc_grad) then
8386 C Explicit gradient in virtual-dihedral angles.
8387         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8388      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8389      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8390         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8391         vv(1)=pizda(1,1)-pizda(2,2)
8392         vv(2)=pizda(1,2)+pizda(2,1)
8393         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8394      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8395      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8396         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8397         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8398         vv(1)=pizda(1,1)-pizda(2,2)
8399         vv(2)=pizda(1,2)+pizda(2,1)
8400         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8401      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8402      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8403 C Cartesian gradient
8404         do iii=1,2
8405           do kkk=1,5
8406             do lll=1,3
8407               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8408      &          pizda(1,1))
8409               vv(1)=pizda(1,1)-pizda(2,2)
8410               vv(2)=pizda(1,2)+pizda(2,1)
8411               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8412      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8413      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8414             enddo
8415           enddo
8416         enddo
8417         endif ! calc_grad
8418 cd        goto 1112
8419 C Contribution from graph IV
8420 1110    continue
8421         call transpose2(EE(1,1,j),auxmat(1,1))
8422         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8423         vv(1)=pizda(1,1)+pizda(2,2)
8424         vv(2)=pizda(2,1)-pizda(1,2)
8425         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8426      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8427         if (calc_grad) then
8428 C Explicit gradient in virtual-dihedral angles.
8429         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8430      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8431         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8432         vv(1)=pizda(1,1)+pizda(2,2)
8433         vv(2)=pizda(2,1)-pizda(1,2)
8434         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8435      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8436      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8437 C Cartesian gradient
8438         do iii=1,2
8439           do kkk=1,5
8440             do lll=1,3
8441               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8442      &          pizda(1,1))
8443               vv(1)=pizda(1,1)+pizda(2,2)
8444               vv(2)=pizda(2,1)-pizda(1,2)
8445               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8446      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8447      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8448             enddo
8449           enddo
8450         enddo
8451         endif ! calc_grad
8452       endif
8453 1112  continue
8454       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8455 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8456 cd        write (2,*) 'ijkl',i,j,k,l
8457 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8458 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8459 cd      endif
8460 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8461 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8462 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8463 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8464       if (calc_grad) then
8465       if (j.lt.nres-1) then
8466         j1=j+1
8467         j2=j-1
8468       else
8469         j1=j-1
8470         j2=j-2
8471       endif
8472       if (l.lt.nres-1) then
8473         l1=l+1
8474         l2=l-1
8475       else
8476         l1=l-1
8477         l2=l-2
8478       endif
8479 cd      eij=1.0d0
8480 cd      ekl=1.0d0
8481 cd      ekont=1.0d0
8482 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8483 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8484 C        summed up outside the subrouine as for the other subroutines
8485 C        handling long-range interactions. The old code is commented out
8486 C        with "cgrad" to keep track of changes.
8487       do ll=1,3
8488 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8489 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8490         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8491         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8492 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8493 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8494 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8495 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8496 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8497 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8498 c     &   gradcorr5ij,
8499 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8500 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8501 cgrad        ghalf=0.5d0*ggg1(ll)
8502 cd        ghalf=0.0d0
8503         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8504         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8505         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8506         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8507         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8508         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8509 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8510 cgrad        ghalf=0.5d0*ggg2(ll)
8511 cd        ghalf=0.0d0
8512         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8513         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8514         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8515         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8516         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8517         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8518       enddo
8519       endif ! calc_grad
8520 cd      goto 1112
8521 cgrad      do m=i+1,j-1
8522 cgrad        do ll=1,3
8523 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8524 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8525 cgrad        enddo
8526 cgrad      enddo
8527 cgrad      do m=k+1,l-1
8528 cgrad        do ll=1,3
8529 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8530 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8531 cgrad        enddo
8532 cgrad      enddo
8533 c1112  continue
8534 cgrad      do m=i+2,j2
8535 cgrad        do ll=1,3
8536 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8537 cgrad        enddo
8538 cgrad      enddo
8539 cgrad      do m=k+2,l2
8540 cgrad        do ll=1,3
8541 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8542 cgrad        enddo
8543 cgrad      enddo
8544 cd      do iii=1,nres-3
8545 cd        write (2,*) iii,g_corr5_loc(iii)
8546 cd      enddo
8547       eello5=ekont*eel5
8548 cd      write (2,*) 'ekont',ekont
8549 cd      write (iout,*) 'eello5',ekont*eel5
8550       return
8551       end
8552 c--------------------------------------------------------------------------
8553       double precision function eello6(i,j,k,l,jj,kk)
8554       implicit real*8 (a-h,o-z)
8555       include 'DIMENSIONS'
8556       include 'DIMENSIONS.ZSCOPT'
8557       include 'COMMON.IOUNITS'
8558       include 'COMMON.CHAIN'
8559       include 'COMMON.DERIV'
8560       include 'COMMON.INTERACT'
8561       include 'COMMON.CONTACTS'
8562       include 'COMMON.CONTMAT'
8563       include 'COMMON.CORRMAT'
8564       include 'COMMON.TORSION'
8565       include 'COMMON.VAR'
8566       include 'COMMON.GEO'
8567       include 'COMMON.FFIELD'
8568       double precision ggg1(3),ggg2(3)
8569 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8570 cd        eello6=0.0d0
8571 cd        return
8572 cd      endif
8573 cd      write (iout,*)
8574 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8575 cd     &   ' and',k,l
8576       eello6_1=0.0d0
8577       eello6_2=0.0d0
8578       eello6_3=0.0d0
8579       eello6_4=0.0d0
8580       eello6_5=0.0d0
8581       eello6_6=0.0d0
8582 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8583 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8584       do iii=1,2
8585         do kkk=1,5
8586           do lll=1,3
8587             derx(lll,kkk,iii)=0.0d0
8588           enddo
8589         enddo
8590       enddo
8591 cd      eij=facont_hb(jj,i)
8592 cd      ekl=facont_hb(kk,k)
8593 cd      ekont=eij*ekl
8594 cd      eij=1.0d0
8595 cd      ekl=1.0d0
8596 cd      ekont=1.0d0
8597       if (l.eq.j+1) then
8598         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8599         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8600         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8601         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8602         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8603         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8604       else
8605         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8606         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8607         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8608         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8609         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8610           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8611         else
8612           eello6_5=0.0d0
8613         endif
8614         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8615       endif
8616 C If turn contributions are considered, they will be handled separately.
8617       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8618 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8619 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8620 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8621 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8622 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8623 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8624 cd      goto 1112
8625       if (calc_grad) then
8626       if (j.lt.nres-1) then
8627         j1=j+1
8628         j2=j-1
8629       else
8630         j1=j-1
8631         j2=j-2
8632       endif
8633       if (l.lt.nres-1) then
8634         l1=l+1
8635         l2=l-1
8636       else
8637         l1=l-1
8638         l2=l-2
8639       endif
8640       do ll=1,3
8641 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8642 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8643 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8644 cgrad        ghalf=0.5d0*ggg1(ll)
8645 cd        ghalf=0.0d0
8646         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8647         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8648         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8649         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8650         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8651         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8652         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8653         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8654 cgrad        ghalf=0.5d0*ggg2(ll)
8655 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8656 cd        ghalf=0.0d0
8657         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8658         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8659         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8660         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8661         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8662         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8663       enddo
8664       endif ! calc_grad
8665 cd      goto 1112
8666 cgrad      do m=i+1,j-1
8667 cgrad        do ll=1,3
8668 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8669 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8670 cgrad        enddo
8671 cgrad      enddo
8672 cgrad      do m=k+1,l-1
8673 cgrad        do ll=1,3
8674 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8675 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8676 cgrad        enddo
8677 cgrad      enddo
8678 cgrad1112  continue
8679 cgrad      do m=i+2,j2
8680 cgrad        do ll=1,3
8681 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8682 cgrad        enddo
8683 cgrad      enddo
8684 cgrad      do m=k+2,l2
8685 cgrad        do ll=1,3
8686 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8687 cgrad        enddo
8688 cgrad      enddo
8689 cd      do iii=1,nres-3
8690 cd        write (2,*) iii,g_corr6_loc(iii)
8691 cd      enddo
8692       eello6=ekont*eel6
8693 cd      write (2,*) 'ekont',ekont
8694 cd      write (iout,*) 'eello6',ekont*eel6
8695       return
8696       end
8697 c--------------------------------------------------------------------------
8698       double precision function eello6_graph1(i,j,k,l,imat,swap)
8699       implicit real*8 (a-h,o-z)
8700       include 'DIMENSIONS'
8701       include 'DIMENSIONS.ZSCOPT'
8702       include 'COMMON.IOUNITS'
8703       include 'COMMON.CHAIN'
8704       include 'COMMON.DERIV'
8705       include 'COMMON.INTERACT'
8706       include 'COMMON.CONTACTS'
8707       include 'COMMON.CONTMAT'
8708       include 'COMMON.CORRMAT'
8709       include 'COMMON.TORSION'
8710       include 'COMMON.VAR'
8711       include 'COMMON.GEO'
8712       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8713       logical swap
8714       logical lprn
8715       common /kutas/ lprn
8716 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8717 C                                                                              C
8718 C      Parallel       Antiparallel                                             C
8719 C                                                                              C
8720 C          o             o                                                     C
8721 C         /l\           /j\                                                    C
8722 C        /   \         /   \                                                   C
8723 C       /| o |         | o |\                                                  C
8724 C     \ j|/k\|  /   \  |/k\|l /                                                C
8725 C      \ /   \ /     \ /   \ /                                                 C
8726 C       o     o       o     o                                                  C
8727 C       i             i                                                        C
8728 C                                                                              C
8729 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8730       itk=itype2loc(itype(k))
8731       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8732       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8733       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8734       call transpose2(EUgC(1,1,k),auxmat(1,1))
8735       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8736       vv1(1)=pizda1(1,1)-pizda1(2,2)
8737       vv1(2)=pizda1(1,2)+pizda1(2,1)
8738       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8739       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8740       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8741       s5=scalar2(vv(1),Dtobr2(1,i))
8742 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8743       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8744       if (calc_grad) then
8745       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8746      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8747      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8748      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8749      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8750      & +scalar2(vv(1),Dtobr2der(1,i)))
8751       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8752       vv1(1)=pizda1(1,1)-pizda1(2,2)
8753       vv1(2)=pizda1(1,2)+pizda1(2,1)
8754       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8755       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8756       if (l.eq.j+1) then
8757         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8758      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8759      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8760      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8761      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8762       else
8763         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8764      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8765      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8766      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8767      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8768       endif
8769       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8770       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8771       vv1(1)=pizda1(1,1)-pizda1(2,2)
8772       vv1(2)=pizda1(1,2)+pizda1(2,1)
8773       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8774      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8775      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8776      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8777       do iii=1,2
8778         if (swap) then
8779           ind=3-iii
8780         else
8781           ind=iii
8782         endif
8783         do kkk=1,5
8784           do lll=1,3
8785             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8786             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8787             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8788             call transpose2(EUgC(1,1,k),auxmat(1,1))
8789             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8790      &        pizda1(1,1))
8791             vv1(1)=pizda1(1,1)-pizda1(2,2)
8792             vv1(2)=pizda1(1,2)+pizda1(2,1)
8793             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8794             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8795      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8796             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8797      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8798             s5=scalar2(vv(1),Dtobr2(1,i))
8799             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8800           enddo
8801         enddo
8802       enddo
8803       endif ! calc_grad
8804       return
8805       end
8806 c----------------------------------------------------------------------------
8807       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8808       implicit real*8 (a-h,o-z)
8809       include 'DIMENSIONS'
8810       include 'DIMENSIONS.ZSCOPT'
8811       include 'COMMON.IOUNITS'
8812       include 'COMMON.CHAIN'
8813       include 'COMMON.DERIV'
8814       include 'COMMON.INTERACT'
8815       include 'COMMON.CONTACTS'
8816       include 'COMMON.CONTMAT'
8817       include 'COMMON.CORRMAT'
8818       include 'COMMON.TORSION'
8819       include 'COMMON.VAR'
8820       include 'COMMON.GEO'
8821       logical swap
8822       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8823      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8824       logical lprn
8825       common /kutas/ lprn
8826 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8827 C                                                                              C
8828 C      Parallel       Antiparallel                                             C
8829 C                                                                              C
8830 C          o             o                                                     C
8831 C     \   /l\           /j\   /                                                C
8832 C      \ /   \         /   \ /                                                 C
8833 C       o| o |         | o |o                                                  C
8834 C     \ j|/k\|      \  |/k\|l                                                  C
8835 C      \ /   \       \ /   \                                                   C
8836 C       o             o                                                        C
8837 C       i             i                                                        C
8838 C                                                                              C
8839 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8840 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8841 C AL 7/4/01 s1 would occur in the sixth-order moment,
8842 C           but not in a cluster cumulant
8843 #ifdef MOMENT
8844       s1=dip(1,jj,i)*dip(1,kk,k)
8845 #endif
8846       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8847       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8848       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8849       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8850       call transpose2(EUg(1,1,k),auxmat(1,1))
8851       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8852       vv(1)=pizda(1,1)-pizda(2,2)
8853       vv(2)=pizda(1,2)+pizda(2,1)
8854       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8855 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8856 #ifdef MOMENT
8857       eello6_graph2=-(s1+s2+s3+s4)
8858 #else
8859       eello6_graph2=-(s2+s3+s4)
8860 #endif
8861 c      eello6_graph2=-s3
8862 C Derivatives in gamma(i-1)
8863       if (calc_grad) then
8864       if (i.gt.1) then
8865 #ifdef MOMENT
8866         s1=dipderg(1,jj,i)*dip(1,kk,k)
8867 #endif
8868         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8869         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8870         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8871         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8872 #ifdef MOMENT
8873         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8874 #else
8875         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8876 #endif
8877 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8878       endif
8879 C Derivatives in gamma(k-1)
8880 #ifdef MOMENT
8881       s1=dip(1,jj,i)*dipderg(1,kk,k)
8882 #endif
8883       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8884       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8885       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8886       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8887       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8888       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8889       vv(1)=pizda(1,1)-pizda(2,2)
8890       vv(2)=pizda(1,2)+pizda(2,1)
8891       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8892 #ifdef MOMENT
8893       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8894 #else
8895       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8896 #endif
8897 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8898 C Derivatives in gamma(j-1) or gamma(l-1)
8899       if (j.gt.1) then
8900 #ifdef MOMENT
8901         s1=dipderg(3,jj,i)*dip(1,kk,k)
8902 #endif
8903         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8904         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8905         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8906         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8907         vv(1)=pizda(1,1)-pizda(2,2)
8908         vv(2)=pizda(1,2)+pizda(2,1)
8909         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8910 #ifdef MOMENT
8911         if (swap) then
8912           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8913         else
8914           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8915         endif
8916 #endif
8917         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8918 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8919       endif
8920 C Derivatives in gamma(l-1) or gamma(j-1)
8921       if (l.gt.1) then
8922 #ifdef MOMENT
8923         s1=dip(1,jj,i)*dipderg(3,kk,k)
8924 #endif
8925         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8926         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8927         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8928         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8929         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8930         vv(1)=pizda(1,1)-pizda(2,2)
8931         vv(2)=pizda(1,2)+pizda(2,1)
8932         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8933 #ifdef MOMENT
8934         if (swap) then
8935           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8936         else
8937           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8938         endif
8939 #endif
8940         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8941 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8942       endif
8943 C Cartesian derivatives.
8944       if (lprn) then
8945         write (2,*) 'In eello6_graph2'
8946         do iii=1,2
8947           write (2,*) 'iii=',iii
8948           do kkk=1,5
8949             write (2,*) 'kkk=',kkk
8950             do jjj=1,2
8951               write (2,'(3(2f10.5),5x)')
8952      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8953             enddo
8954           enddo
8955         enddo
8956       endif
8957       do iii=1,2
8958         do kkk=1,5
8959           do lll=1,3
8960 #ifdef MOMENT
8961             if (iii.eq.1) then
8962               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8963             else
8964               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8965             endif
8966 #endif
8967             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8968      &        auxvec(1))
8969             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8970             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8971      &        auxvec(1))
8972             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8973             call transpose2(EUg(1,1,k),auxmat(1,1))
8974             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8975      &        pizda(1,1))
8976             vv(1)=pizda(1,1)-pizda(2,2)
8977             vv(2)=pizda(1,2)+pizda(2,1)
8978             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8979 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8980 #ifdef MOMENT
8981             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8982 #else
8983             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8984 #endif
8985             if (swap) then
8986               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8987             else
8988               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8989             endif
8990           enddo
8991         enddo
8992       enddo
8993       endif ! calc_grad
8994       return
8995       end
8996 c----------------------------------------------------------------------------
8997       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8998       implicit real*8 (a-h,o-z)
8999       include 'DIMENSIONS'
9000       include 'DIMENSIONS.ZSCOPT'
9001       include 'COMMON.IOUNITS'
9002       include 'COMMON.CHAIN'
9003       include 'COMMON.DERIV'
9004       include 'COMMON.INTERACT'
9005       include 'COMMON.CONTACTS'
9006       include 'COMMON.CONTMAT'
9007       include 'COMMON.CORRMAT'
9008       include 'COMMON.TORSION'
9009       include 'COMMON.VAR'
9010       include 'COMMON.GEO'
9011       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9012       logical swap
9013 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9014 C                                                                              C
9015 C      Parallel       Antiparallel                                             C
9016 C                                                                              C
9017 C          o             o                                                     C
9018 C         /l\   /   \   /j\                                                    C
9019 C        /   \ /     \ /   \                                                   C
9020 C       /| o |o       o| o |\                                                  C
9021 C       j|/k\|  /      |/k\|l /                                                C
9022 C        /   \ /       /   \ /                                                 C
9023 C       /     o       /     o                                                  C
9024 C       i             i                                                        C
9025 C                                                                              C
9026 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9027 C
9028 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9029 C           energy moment and not to the cluster cumulant.
9030       iti=itortyp(itype(i))
9031       if (j.lt.nres-1) then
9032         itj1=itype2loc(itype(j+1))
9033       else
9034         itj1=nloctyp
9035       endif
9036       itk=itype2loc(itype(k))
9037       itk1=itype2loc(itype(k+1))
9038       if (l.lt.nres-1) then
9039         itl1=itype2loc(itype(l+1))
9040       else
9041         itl1=nloctyp
9042       endif
9043 #ifdef MOMENT
9044       s1=dip(4,jj,i)*dip(4,kk,k)
9045 #endif
9046       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9047       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9048       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9049       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9050       call transpose2(EE(1,1,k),auxmat(1,1))
9051       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9052       vv(1)=pizda(1,1)+pizda(2,2)
9053       vv(2)=pizda(2,1)-pizda(1,2)
9054       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9055 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9056 cd     & "sum",-(s2+s3+s4)
9057 #ifdef MOMENT
9058       eello6_graph3=-(s1+s2+s3+s4)
9059 #else
9060       eello6_graph3=-(s2+s3+s4)
9061 #endif
9062 c      eello6_graph3=-s4
9063 C Derivatives in gamma(k-1)
9064       if (calc_grad) then
9065       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9066       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9067       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9068       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9069 C Derivatives in gamma(l-1)
9070       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9071       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9072       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9073       vv(1)=pizda(1,1)+pizda(2,2)
9074       vv(2)=pizda(2,1)-pizda(1,2)
9075       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9076       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9077 C Cartesian derivatives.
9078       do iii=1,2
9079         do kkk=1,5
9080           do lll=1,3
9081 #ifdef MOMENT
9082             if (iii.eq.1) then
9083               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9084             else
9085               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9086             endif
9087 #endif
9088             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9089      &        auxvec(1))
9090             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9091             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9092      &        auxvec(1))
9093             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9094             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9095      &        pizda(1,1))
9096             vv(1)=pizda(1,1)+pizda(2,2)
9097             vv(2)=pizda(2,1)-pizda(1,2)
9098             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9099 #ifdef MOMENT
9100             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9101 #else
9102             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9103 #endif
9104             if (swap) then
9105               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9106             else
9107               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9108             endif
9109 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9110           enddo
9111         enddo
9112       enddo
9113       endif ! calc_grad
9114       return
9115       end
9116 c----------------------------------------------------------------------------
9117       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9118       implicit real*8 (a-h,o-z)
9119       include 'DIMENSIONS'
9120       include 'DIMENSIONS.ZSCOPT'
9121       include 'COMMON.IOUNITS'
9122       include 'COMMON.CHAIN'
9123       include 'COMMON.DERIV'
9124       include 'COMMON.INTERACT'
9125       include 'COMMON.CONTACTS'
9126       include 'COMMON.CONTMAT'
9127       include 'COMMON.CORRMAT'
9128       include 'COMMON.TORSION'
9129       include 'COMMON.VAR'
9130       include 'COMMON.GEO'
9131       include 'COMMON.FFIELD'
9132       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9133      & auxvec1(2),auxmat1(2,2)
9134       logical swap
9135 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9136 C                                                                              C
9137 C      Parallel       Antiparallel                                             C
9138 C                                                                              C
9139 C          o             o                                                     C
9140 C         /l\   /   \   /j\                                                    C
9141 C        /   \ /     \ /   \                                                   C
9142 C       /| o |o       o| o |\                                                  C
9143 C     \ j|/k\|      \  |/k\|l                                                  C
9144 C      \ /   \       \ /   \                                                   C
9145 C       o     \       o     \                                                  C
9146 C       i             i                                                        C
9147 C                                                                              C
9148 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9149 C
9150 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9151 C           energy moment and not to the cluster cumulant.
9152 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9153       iti=itype2loc(itype(i))
9154       itj=itype2loc(itype(j))
9155       if (j.lt.nres-1) then
9156         itj1=itype2loc(itype(j+1))
9157       else
9158         itj1=nloctyp
9159       endif
9160       itk=itype2loc(itype(k))
9161       if (k.lt.nres-1) then
9162         itk1=itype2loc(itype(k+1))
9163       else
9164         itk1=nloctyp
9165       endif
9166       itl=itype2loc(itype(l))
9167       if (l.lt.nres-1) then
9168         itl1=itype2loc(itype(l+1))
9169       else
9170         itl1=nloctyp
9171       endif
9172 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9173 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9174 cd     & ' itl',itl,' itl1',itl1
9175 #ifdef MOMENT
9176       if (imat.eq.1) then
9177         s1=dip(3,jj,i)*dip(3,kk,k)
9178       else
9179         s1=dip(2,jj,j)*dip(2,kk,l)
9180       endif
9181 #endif
9182       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9183       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9184       if (j.eq.l+1) then
9185         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9186         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9187       else
9188         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9189         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9190       endif
9191       call transpose2(EUg(1,1,k),auxmat(1,1))
9192       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9193       vv(1)=pizda(1,1)-pizda(2,2)
9194       vv(2)=pizda(2,1)+pizda(1,2)
9195       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9196 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9197 #ifdef MOMENT
9198       eello6_graph4=-(s1+s2+s3+s4)
9199 #else
9200       eello6_graph4=-(s2+s3+s4)
9201 #endif
9202 C Derivatives in gamma(i-1)
9203       if (calc_grad) then
9204       if (i.gt.1) then
9205 #ifdef MOMENT
9206         if (imat.eq.1) then
9207           s1=dipderg(2,jj,i)*dip(3,kk,k)
9208         else
9209           s1=dipderg(4,jj,j)*dip(2,kk,l)
9210         endif
9211 #endif
9212         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9213         if (j.eq.l+1) then
9214           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9215           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9216         else
9217           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9218           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9219         endif
9220         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9221         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9222 cd          write (2,*) 'turn6 derivatives'
9223 #ifdef MOMENT
9224           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9225 #else
9226           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9227 #endif
9228         else
9229 #ifdef MOMENT
9230           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9231 #else
9232           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9233 #endif
9234         endif
9235       endif
9236 C Derivatives in gamma(k-1)
9237 #ifdef MOMENT
9238       if (imat.eq.1) then
9239         s1=dip(3,jj,i)*dipderg(2,kk,k)
9240       else
9241         s1=dip(2,jj,j)*dipderg(4,kk,l)
9242       endif
9243 #endif
9244       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9245       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9246       if (j.eq.l+1) then
9247         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9248         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9249       else
9250         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9251         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9252       endif
9253       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9254       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9255       vv(1)=pizda(1,1)-pizda(2,2)
9256       vv(2)=pizda(2,1)+pizda(1,2)
9257       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9258       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9259 #ifdef MOMENT
9260         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9261 #else
9262         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9263 #endif
9264       else
9265 #ifdef MOMENT
9266         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9267 #else
9268         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9269 #endif
9270       endif
9271 C Derivatives in gamma(j-1) or gamma(l-1)
9272       if (l.eq.j+1 .and. l.gt.1) then
9273         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9274         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9275         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9276         vv(1)=pizda(1,1)-pizda(2,2)
9277         vv(2)=pizda(2,1)+pizda(1,2)
9278         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9279         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9280       else if (j.gt.1) then
9281         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9282         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9283         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9284         vv(1)=pizda(1,1)-pizda(2,2)
9285         vv(2)=pizda(2,1)+pizda(1,2)
9286         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9287         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9288           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9289         else
9290           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9291         endif
9292       endif
9293 C Cartesian derivatives.
9294       do iii=1,2
9295         do kkk=1,5
9296           do lll=1,3
9297 #ifdef MOMENT
9298             if (iii.eq.1) then
9299               if (imat.eq.1) then
9300                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9301               else
9302                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9303               endif
9304             else
9305               if (imat.eq.1) then
9306                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9307               else
9308                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9309               endif
9310             endif
9311 #endif
9312             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9313      &        auxvec(1))
9314             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9315             if (j.eq.l+1) then
9316               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9317      &          b1(1,j+1),auxvec(1))
9318               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9319             else
9320               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9321      &          b1(1,l+1),auxvec(1))
9322               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9323             endif
9324             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9325      &        pizda(1,1))
9326             vv(1)=pizda(1,1)-pizda(2,2)
9327             vv(2)=pizda(2,1)+pizda(1,2)
9328             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9329             if (swap) then
9330               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9331 #ifdef MOMENT
9332                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9333      &             -(s1+s2+s4)
9334 #else
9335                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9336      &             -(s2+s4)
9337 #endif
9338                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9339               else
9340 #ifdef MOMENT
9341                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9342 #else
9343                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9344 #endif
9345                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9346               endif
9347             else
9348 #ifdef MOMENT
9349               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9350 #else
9351               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9352 #endif
9353               if (l.eq.j+1) then
9354                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9355               else
9356                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9357               endif
9358             endif
9359           enddo
9360         enddo
9361       enddo
9362       endif ! calc_grad
9363       return
9364       end
9365 c----------------------------------------------------------------------------
9366       double precision function eello_turn6(i,jj,kk)
9367       implicit real*8 (a-h,o-z)
9368       include 'DIMENSIONS'
9369       include 'DIMENSIONS.ZSCOPT'
9370       include 'COMMON.IOUNITS'
9371       include 'COMMON.CHAIN'
9372       include 'COMMON.DERIV'
9373       include 'COMMON.INTERACT'
9374       include 'COMMON.CONTACTS'
9375       include 'COMMON.CONTMAT'
9376       include 'COMMON.CORRMAT'
9377       include 'COMMON.TORSION'
9378       include 'COMMON.VAR'
9379       include 'COMMON.GEO'
9380       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9381      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9382      &  ggg1(3),ggg2(3)
9383       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9384      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9385 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9386 C           the respective energy moment and not to the cluster cumulant.
9387       s1=0.0d0
9388       s8=0.0d0
9389       s13=0.0d0
9390 c
9391       eello_turn6=0.0d0
9392       j=i+4
9393       k=i+1
9394       l=i+3
9395       iti=itype2loc(itype(i))
9396       itk=itype2loc(itype(k))
9397       itk1=itype2loc(itype(k+1))
9398       itl=itype2loc(itype(l))
9399       itj=itype2loc(itype(j))
9400 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9401 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9402 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9403 cd        eello6=0.0d0
9404 cd        return
9405 cd      endif
9406 cd      write (iout,*)
9407 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9408 cd     &   ' and',k,l
9409 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9410       do iii=1,2
9411         do kkk=1,5
9412           do lll=1,3
9413             derx_turn(lll,kkk,iii)=0.0d0
9414           enddo
9415         enddo
9416       enddo
9417 cd      eij=1.0d0
9418 cd      ekl=1.0d0
9419 cd      ekont=1.0d0
9420       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9421 cd      eello6_5=0.0d0
9422 cd      write (2,*) 'eello6_5',eello6_5
9423 #ifdef MOMENT
9424       call transpose2(AEA(1,1,1),auxmat(1,1))
9425       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9426       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9427       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9428 #endif
9429       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9430       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9431       s2 = scalar2(b1(1,k),vtemp1(1))
9432 #ifdef MOMENT
9433       call transpose2(AEA(1,1,2),atemp(1,1))
9434       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9435       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9436       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9437 #endif
9438       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9439       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9440       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9441 #ifdef MOMENT
9442       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9443       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9444       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9445       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9446       ss13 = scalar2(b1(1,k),vtemp4(1))
9447       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9448 #endif
9449 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9450 c      s1=0.0d0
9451 c      s2=0.0d0
9452 c      s8=0.0d0
9453 c      s12=0.0d0
9454 c      s13=0.0d0
9455       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9456 C Derivatives in gamma(i+2)
9457       if (calc_grad) then
9458       s1d =0.0d0
9459       s8d =0.0d0
9460 #ifdef MOMENT
9461       call transpose2(AEA(1,1,1),auxmatd(1,1))
9462       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9463       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9464       call transpose2(AEAderg(1,1,2),atempd(1,1))
9465       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9466       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9467 #endif
9468       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9469       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9470       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9471 c      s1d=0.0d0
9472 c      s2d=0.0d0
9473 c      s8d=0.0d0
9474 c      s12d=0.0d0
9475 c      s13d=0.0d0
9476       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9477 C Derivatives in gamma(i+3)
9478 #ifdef MOMENT
9479       call transpose2(AEA(1,1,1),auxmatd(1,1))
9480       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9481       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9482       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9483 #endif
9484       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9485       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9486       s2d = scalar2(b1(1,k),vtemp1d(1))
9487 #ifdef MOMENT
9488       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9489       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9490 #endif
9491       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9492 #ifdef MOMENT
9493       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9494       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9495       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9496 #endif
9497 c      s1d=0.0d0
9498 c      s2d=0.0d0
9499 c      s8d=0.0d0
9500 c      s12d=0.0d0
9501 c      s13d=0.0d0
9502 #ifdef MOMENT
9503       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9504      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9505 #else
9506       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9507      &               -0.5d0*ekont*(s2d+s12d)
9508 #endif
9509 C Derivatives in gamma(i+4)
9510       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9511       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9512       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9513 #ifdef MOMENT
9514       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9515       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9516       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9517 #endif
9518 c      s1d=0.0d0
9519 c      s2d=0.0d0
9520 c      s8d=0.0d0
9521 C      s12d=0.0d0
9522 c      s13d=0.0d0
9523 #ifdef MOMENT
9524       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9525 #else
9526       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9527 #endif
9528 C Derivatives in gamma(i+5)
9529 #ifdef MOMENT
9530       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9531       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9532       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9533 #endif
9534       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9535       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9536       s2d = scalar2(b1(1,k),vtemp1d(1))
9537 #ifdef MOMENT
9538       call transpose2(AEA(1,1,2),atempd(1,1))
9539       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9540       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9541 #endif
9542       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9543       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9544 #ifdef MOMENT
9545       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9546       ss13d = scalar2(b1(1,k),vtemp4d(1))
9547       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9548 #endif
9549 c      s1d=0.0d0
9550 c      s2d=0.0d0
9551 c      s8d=0.0d0
9552 c      s12d=0.0d0
9553 c      s13d=0.0d0
9554 #ifdef MOMENT
9555       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9556      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9557 #else
9558       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9559      &               -0.5d0*ekont*(s2d+s12d)
9560 #endif
9561 C Cartesian derivatives
9562       do iii=1,2
9563         do kkk=1,5
9564           do lll=1,3
9565 #ifdef MOMENT
9566             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9567             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9568             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9569 #endif
9570             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9571             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9572      &          vtemp1d(1))
9573             s2d = scalar2(b1(1,k),vtemp1d(1))
9574 #ifdef MOMENT
9575             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9576             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9577             s8d = -(atempd(1,1)+atempd(2,2))*
9578      &           scalar2(cc(1,1,l),vtemp2(1))
9579 #endif
9580             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9581      &           auxmatd(1,1))
9582             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9583             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9584 c      s1d=0.0d0
9585 c      s2d=0.0d0
9586 c      s8d=0.0d0
9587 c      s12d=0.0d0
9588 c      s13d=0.0d0
9589 #ifdef MOMENT
9590             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9591      &        - 0.5d0*(s1d+s2d)
9592 #else
9593             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9594      &        - 0.5d0*s2d
9595 #endif
9596 #ifdef MOMENT
9597             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9598      &        - 0.5d0*(s8d+s12d)
9599 #else
9600             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9601      &        - 0.5d0*s12d
9602 #endif
9603           enddo
9604         enddo
9605       enddo
9606 #ifdef MOMENT
9607       do kkk=1,5
9608         do lll=1,3
9609           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9610      &      achuj_tempd(1,1))
9611           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9612           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9613           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9614           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9615           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9616      &      vtemp4d(1))
9617           ss13d = scalar2(b1(1,k),vtemp4d(1))
9618           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9619           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9620         enddo
9621       enddo
9622 #endif
9623 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9624 cd     &  16*eel_turn6_num
9625 cd      goto 1112
9626       if (j.lt.nres-1) then
9627         j1=j+1
9628         j2=j-1
9629       else
9630         j1=j-1
9631         j2=j-2
9632       endif
9633       if (l.lt.nres-1) then
9634         l1=l+1
9635         l2=l-1
9636       else
9637         l1=l-1
9638         l2=l-2
9639       endif
9640       do ll=1,3
9641 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9642 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9643 cgrad        ghalf=0.5d0*ggg1(ll)
9644 cd        ghalf=0.0d0
9645         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9646         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9647         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9648      &    +ekont*derx_turn(ll,2,1)
9649         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9650         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9651      &    +ekont*derx_turn(ll,4,1)
9652         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9653         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9654         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9655 cgrad        ghalf=0.5d0*ggg2(ll)
9656 cd        ghalf=0.0d0
9657         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9658      &    +ekont*derx_turn(ll,2,2)
9659         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9660         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9661      &    +ekont*derx_turn(ll,4,2)
9662         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9663         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9664         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9665       enddo
9666 cd      goto 1112
9667 cgrad      do m=i+1,j-1
9668 cgrad        do ll=1,3
9669 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9670 cgrad        enddo
9671 cgrad      enddo
9672 cgrad      do m=k+1,l-1
9673 cgrad        do ll=1,3
9674 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9675 cgrad        enddo
9676 cgrad      enddo
9677 cgrad1112  continue
9678 cgrad      do m=i+2,j2
9679 cgrad        do ll=1,3
9680 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9681 cgrad        enddo
9682 cgrad      enddo
9683 cgrad      do m=k+2,l2
9684 cgrad        do ll=1,3
9685 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9686 cgrad        enddo
9687 cgrad      enddo
9688 cd      do iii=1,nres-3
9689 cd        write (2,*) iii,g_corr6_loc(iii)
9690 cd      enddo
9691       endif ! calc_grad
9692       eello_turn6=ekont*eel_turn6
9693 cd      write (2,*) 'ekont',ekont
9694 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9695       return
9696       end
9697 #endif
9698 crc-------------------------------------------------
9699 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9700       subroutine Eliptransfer(eliptran)
9701       implicit real*8 (a-h,o-z)
9702       include 'DIMENSIONS'
9703       include 'DIMENSIONS.ZSCOPT'
9704       include 'COMMON.GEO'
9705       include 'COMMON.VAR'
9706       include 'COMMON.LOCAL'
9707       include 'COMMON.CHAIN'
9708       include 'COMMON.DERIV'
9709       include 'COMMON.INTERACT'
9710       include 'COMMON.IOUNITS'
9711       include 'COMMON.CALC'
9712       include 'COMMON.CONTROL'
9713       include 'COMMON.SPLITELE'
9714       include 'COMMON.SBRIDGE'
9715 C this is done by Adasko
9716 C      print *,"wchodze"
9717 C structure of box:
9718 C      water
9719 C--bordliptop-- buffore starts
9720 C--bufliptop--- here true lipid starts
9721 C      lipid
9722 C--buflipbot--- lipid ends buffore starts
9723 C--bordlipbot--buffore ends
9724       eliptran=0.0
9725       do i=1,nres
9726 C       do i=1,1
9727         if (itype(i).eq.ntyp1) cycle
9728
9729         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9730         if (positi.le.0) positi=positi+boxzsize
9731 C        print *,i
9732 C first for peptide groups
9733 c for each residue check if it is in lipid or lipid water border area
9734        if ((positi.gt.bordlipbot)
9735      &.and.(positi.lt.bordliptop)) then
9736 C the energy transfer exist
9737         if (positi.lt.buflipbot) then
9738 C what fraction I am in
9739          fracinbuf=1.0d0-
9740      &        ((positi-bordlipbot)/lipbufthick)
9741 C lipbufthick is thickenes of lipid buffore
9742          sslip=sscalelip(fracinbuf)
9743          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9744          eliptran=eliptran+sslip*pepliptran
9745          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9746          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9747 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9748         elseif (positi.gt.bufliptop) then
9749          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9750          sslip=sscalelip(fracinbuf)
9751          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9752          eliptran=eliptran+sslip*pepliptran
9753          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9754          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9755 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9756 C          print *, "doing sscalefor top part"
9757 C         print *,i,sslip,fracinbuf,ssgradlip
9758         else
9759          eliptran=eliptran+pepliptran
9760 C         print *,"I am in true lipid"
9761         endif
9762 C       else
9763 C       eliptran=elpitran+0.0 ! I am in water
9764        endif
9765        enddo
9766 C       print *, "nic nie bylo w lipidzie?"
9767 C now multiply all by the peptide group transfer factor
9768 C       eliptran=eliptran*pepliptran
9769 C now the same for side chains
9770 CV       do i=1,1
9771        do i=1,nres
9772         if (itype(i).eq.ntyp1) cycle
9773         positi=(mod(c(3,i+nres),boxzsize))
9774         if (positi.le.0) positi=positi+boxzsize
9775 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9776 c for each residue check if it is in lipid or lipid water border area
9777 C       respos=mod(c(3,i+nres),boxzsize)
9778 C       print *,positi,bordlipbot,buflipbot
9779        if ((positi.gt.bordlipbot)
9780      & .and.(positi.lt.bordliptop)) then
9781 C the energy transfer exist
9782         if (positi.lt.buflipbot) then
9783          fracinbuf=1.0d0-
9784      &     ((positi-bordlipbot)/lipbufthick)
9785 C lipbufthick is thickenes of lipid buffore
9786          sslip=sscalelip(fracinbuf)
9787          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9788          eliptran=eliptran+sslip*liptranene(itype(i))
9789          gliptranx(3,i)=gliptranx(3,i)
9790      &+ssgradlip*liptranene(itype(i))
9791          gliptranc(3,i-1)= gliptranc(3,i-1)
9792      &+ssgradlip*liptranene(itype(i))
9793 C         print *,"doing sccale for lower part"
9794         elseif (positi.gt.bufliptop) then
9795          fracinbuf=1.0d0-
9796      &((bordliptop-positi)/lipbufthick)
9797          sslip=sscalelip(fracinbuf)
9798          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9799          eliptran=eliptran+sslip*liptranene(itype(i))
9800          gliptranx(3,i)=gliptranx(3,i)
9801      &+ssgradlip*liptranene(itype(i))
9802          gliptranc(3,i-1)= gliptranc(3,i-1)
9803      &+ssgradlip*liptranene(itype(i))
9804 C          print *, "doing sscalefor top part",sslip,fracinbuf
9805         else
9806          eliptran=eliptran+liptranene(itype(i))
9807 C         print *,"I am in true lipid"
9808         endif
9809         endif ! if in lipid or buffor
9810 C       else
9811 C       eliptran=elpitran+0.0 ! I am in water
9812        enddo
9813        return
9814        end
9815
9816
9817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9818
9819       SUBROUTINE MATVEC2(A1,V1,V2)
9820       implicit real*8 (a-h,o-z)
9821       include 'DIMENSIONS'
9822       DIMENSION A1(2,2),V1(2),V2(2)
9823 c      DO 1 I=1,2
9824 c        VI=0.0
9825 c        DO 3 K=1,2
9826 c    3     VI=VI+A1(I,K)*V1(K)
9827 c        Vaux(I)=VI
9828 c    1 CONTINUE
9829
9830       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9831       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9832
9833       v2(1)=vaux1
9834       v2(2)=vaux2
9835       END
9836 C---------------------------------------
9837       SUBROUTINE MATMAT2(A1,A2,A3)
9838       implicit real*8 (a-h,o-z)
9839       include 'DIMENSIONS'
9840       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9841 c      DIMENSION AI3(2,2)
9842 c        DO  J=1,2
9843 c          A3IJ=0.0
9844 c          DO K=1,2
9845 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9846 c          enddo
9847 c          A3(I,J)=A3IJ
9848 c       enddo
9849 c      enddo
9850
9851       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9852       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9853       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9854       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9855
9856       A3(1,1)=AI3_11
9857       A3(2,1)=AI3_21
9858       A3(1,2)=AI3_12
9859       A3(2,2)=AI3_22
9860       END
9861
9862 c-------------------------------------------------------------------------
9863       double precision function scalar2(u,v)
9864       implicit none
9865       double precision u(2),v(2)
9866       double precision sc
9867       integer i
9868       scalar2=u(1)*v(1)+u(2)*v(2)
9869       return
9870       end
9871
9872 C-----------------------------------------------------------------------------
9873
9874       subroutine transpose2(a,at)
9875       implicit none
9876       double precision a(2,2),at(2,2)
9877       at(1,1)=a(1,1)
9878       at(1,2)=a(2,1)
9879       at(2,1)=a(1,2)
9880       at(2,2)=a(2,2)
9881       return
9882       end
9883 c--------------------------------------------------------------------------
9884       subroutine transpose(n,a,at)
9885       implicit none
9886       integer n,i,j
9887       double precision a(n,n),at(n,n)
9888       do i=1,n
9889         do j=1,n
9890           at(j,i)=a(i,j)
9891         enddo
9892       enddo
9893       return
9894       end
9895 C---------------------------------------------------------------------------
9896       subroutine prodmat3(a1,a2,kk,transp,prod)
9897       implicit none
9898       integer i,j
9899       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9900       logical transp
9901 crc      double precision auxmat(2,2),prod_(2,2)
9902
9903       if (transp) then
9904 crc        call transpose2(kk(1,1),auxmat(1,1))
9905 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9906 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9907
9908            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9909      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9910            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9911      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9912            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9913      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9914            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9915      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9916
9917       else
9918 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9919 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9920
9921            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9922      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9923            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9924      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9925            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9926      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9927            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9928      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9929
9930       endif
9931 c      call transpose2(a2(1,1),a2t(1,1))
9932
9933 crc      print *,transp
9934 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9935 crc      print *,((prod(i,j),i=1,2),j=1,2)
9936
9937       return
9938       end
9939 C-----------------------------------------------------------------------------
9940       double precision function scalar(u,v)
9941       implicit none
9942       double precision u(3),v(3)
9943       double precision sc
9944       integer i
9945       sc=0.0d0
9946       do i=1,3
9947         sc=sc+u(i)*v(i)
9948       enddo
9949       scalar=sc
9950       return
9951       end
9952 C-----------------------------------------------------------------------
9953       double precision function sscale(r)
9954       double precision r,gamm
9955       include "COMMON.SPLITELE"
9956       if(r.lt.r_cut-rlamb) then
9957         sscale=1.0d0
9958       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9959         gamm=(r-(r_cut-rlamb))/rlamb
9960         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9961       else
9962         sscale=0d0
9963       endif
9964       return
9965       end
9966 C-----------------------------------------------------------------------
9967 C-----------------------------------------------------------------------
9968       double precision function sscagrad(r)
9969       double precision r,gamm
9970       include "COMMON.SPLITELE"
9971       if(r.lt.r_cut-rlamb) then
9972         sscagrad=0.0d0
9973       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9974         gamm=(r-(r_cut-rlamb))/rlamb
9975         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9976       else
9977         sscagrad=0.0d0
9978       endif
9979       return
9980       end
9981 C-----------------------------------------------------------------------
9982 C-----------------------------------------------------------------------
9983       double precision function sscalelip(r)
9984       double precision r,gamm
9985       include "COMMON.SPLITELE"
9986 C      if(r.lt.r_cut-rlamb) then
9987 C        sscale=1.0d0
9988 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9989 C        gamm=(r-(r_cut-rlamb))/rlamb
9990         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9991 C      else
9992 C        sscale=0d0
9993 C      endif
9994       return
9995       end
9996 C-----------------------------------------------------------------------
9997       double precision function sscagradlip(r)
9998       double precision r,gamm
9999       include "COMMON.SPLITELE"
10000 C     if(r.lt.r_cut-rlamb) then
10001 C        sscagrad=0.0d0
10002 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10003 C        gamm=(r-(r_cut-rlamb))/rlamb
10004         sscagradlip=r*(6*r-6.0d0)
10005 C      else
10006 C        sscagrad=0.0d0
10007 C      endif
10008       return
10009       end
10010
10011 C-----------------------------------------------------------------------
10012        subroutine set_shield_fac
10013       implicit real*8 (a-h,o-z)
10014       include 'DIMENSIONS'
10015       include 'DIMENSIONS.ZSCOPT'
10016       include 'COMMON.CHAIN'
10017       include 'COMMON.DERIV'
10018       include 'COMMON.IOUNITS'
10019       include 'COMMON.SHIELD'
10020       include 'COMMON.INTERACT'
10021 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10022       double precision div77_81/0.974996043d0/,
10023      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10024
10025 C the vector between center of side_chain and peptide group
10026        double precision pep_side(3),long,side_calf(3),
10027      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10028      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10029 C the line belowe needs to be changed for FGPROC>1
10030       do i=1,nres-1
10031       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10032       ishield_list(i)=0
10033 Cif there two consequtive dummy atoms there is no peptide group between them
10034 C the line below has to be changed for FGPROC>1
10035       VolumeTotal=0.0
10036       do k=1,nres
10037        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10038        dist_pep_side=0.0
10039        dist_side_calf=0.0
10040        do j=1,3
10041 C first lets set vector conecting the ithe side-chain with kth side-chain
10042       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10043 C      pep_side(j)=2.0d0
10044 C and vector conecting the side-chain with its proper calfa
10045       side_calf(j)=c(j,k+nres)-c(j,k)
10046 C      side_calf(j)=2.0d0
10047       pept_group(j)=c(j,i)-c(j,i+1)
10048 C lets have their lenght
10049       dist_pep_side=pep_side(j)**2+dist_pep_side
10050       dist_side_calf=dist_side_calf+side_calf(j)**2
10051       dist_pept_group=dist_pept_group+pept_group(j)**2
10052       enddo
10053        dist_pep_side=dsqrt(dist_pep_side)
10054        dist_pept_group=dsqrt(dist_pept_group)
10055        dist_side_calf=dsqrt(dist_side_calf)
10056       do j=1,3
10057         pep_side_norm(j)=pep_side(j)/dist_pep_side
10058         side_calf_norm(j)=dist_side_calf
10059       enddo
10060 C now sscale fraction
10061        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10062 C       print *,buff_shield,"buff"
10063 C now sscale
10064         if (sh_frac_dist.le.0.0) cycle
10065 C If we reach here it means that this side chain reaches the shielding sphere
10066 C Lets add him to the list for gradient
10067         ishield_list(i)=ishield_list(i)+1
10068 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10069 C this list is essential otherwise problem would be O3
10070         shield_list(ishield_list(i),i)=k
10071 C Lets have the sscale value
10072         if (sh_frac_dist.gt.1.0) then
10073          scale_fac_dist=1.0d0
10074          do j=1,3
10075          sh_frac_dist_grad(j)=0.0d0
10076          enddo
10077         else
10078          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10079      &                   *(2.0*sh_frac_dist-3.0d0)
10080          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10081      &                  /dist_pep_side/buff_shield*0.5
10082 C remember for the final gradient multiply sh_frac_dist_grad(j)
10083 C for side_chain by factor -2 !
10084          do j=1,3
10085          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10086 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10087 C     &                    sh_frac_dist_grad(j)
10088          enddo
10089         endif
10090 C        if ((i.eq.3).and.(k.eq.2)) then
10091 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10092 C     & ,"TU"
10093 C        endif
10094
10095 C this is what is now we have the distance scaling now volume...
10096       short=short_r_sidechain(itype(k))
10097       long=long_r_sidechain(itype(k))
10098       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10099 C now costhet_grad
10100 C       costhet=0.0d0
10101        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10102 C       costhet_fac=0.0d0
10103        do j=1,3
10104          costhet_grad(j)=costhet_fac*pep_side(j)
10105        enddo
10106 C remember for the final gradient multiply costhet_grad(j)
10107 C for side_chain by factor -2 !
10108 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10109 C pep_side0pept_group is vector multiplication
10110       pep_side0pept_group=0.0
10111       do j=1,3
10112       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10113       enddo
10114       cosalfa=(pep_side0pept_group/
10115      & (dist_pep_side*dist_side_calf))
10116       fac_alfa_sin=1.0-cosalfa**2
10117       fac_alfa_sin=dsqrt(fac_alfa_sin)
10118       rkprim=fac_alfa_sin*(long-short)+short
10119 C now costhet_grad
10120        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10121        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10122
10123        do j=1,3
10124          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10125      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10126      &*(long-short)/fac_alfa_sin*cosalfa/
10127      &((dist_pep_side*dist_side_calf))*
10128      &((side_calf(j))-cosalfa*
10129      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10130
10131         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10132      &*(long-short)/fac_alfa_sin*cosalfa
10133      &/((dist_pep_side*dist_side_calf))*
10134      &(pep_side(j)-
10135      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10136        enddo
10137
10138       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10139      &                    /VSolvSphere_div
10140      &                    *wshield
10141 C now the gradient...
10142 C grad_shield is gradient of Calfa for peptide groups
10143 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10144 C     &               costhet,cosphi
10145 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10146 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10147       do j=1,3
10148       grad_shield(j,i)=grad_shield(j,i)
10149 C gradient po skalowaniu
10150      &                +(sh_frac_dist_grad(j)
10151 C  gradient po costhet
10152      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10153      &-scale_fac_dist*(cosphi_grad_long(j))
10154      &/(1.0-cosphi) )*div77_81
10155      &*VofOverlap
10156 C grad_shield_side is Cbeta sidechain gradient
10157       grad_shield_side(j,ishield_list(i),i)=
10158      &        (sh_frac_dist_grad(j)*(-2.0d0)
10159      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10160      &       +scale_fac_dist*(cosphi_grad_long(j))
10161      &        *2.0d0/(1.0-cosphi))
10162      &        *div77_81*VofOverlap
10163
10164        grad_shield_loc(j,ishield_list(i),i)=
10165      &   scale_fac_dist*cosphi_grad_loc(j)
10166      &        *2.0d0/(1.0-cosphi)
10167      &        *div77_81*VofOverlap
10168       enddo
10169       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10170       enddo
10171       fac_shield(i)=VolumeTotal*div77_81+div4_81
10172 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10173       enddo
10174       return
10175       end
10176 C--------------------------------------------------------------------------
10177 C first for shielding is setting of function of side-chains
10178        subroutine set_shield_fac2
10179       implicit real*8 (a-h,o-z)
10180       include 'DIMENSIONS'
10181       include 'DIMENSIONS.ZSCOPT'
10182       include 'COMMON.CHAIN'
10183       include 'COMMON.DERIV'
10184       include 'COMMON.IOUNITS'
10185       include 'COMMON.SHIELD'
10186       include 'COMMON.INTERACT'
10187 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10188       double precision div77_81/0.974996043d0/,
10189      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10190
10191 C the vector between center of side_chain and peptide group
10192        double precision pep_side(3),long,side_calf(3),
10193      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10194      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10195 C the line belowe needs to be changed for FGPROC>1
10196       do i=1,nres-1
10197       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10198       ishield_list(i)=0
10199 Cif there two consequtive dummy atoms there is no peptide group between them
10200 C the line below has to be changed for FGPROC>1
10201       VolumeTotal=0.0
10202       do k=1,nres
10203        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10204        dist_pep_side=0.0
10205        dist_side_calf=0.0
10206        do j=1,3
10207 C first lets set vector conecting the ithe side-chain with kth side-chain
10208       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10209 C      pep_side(j)=2.0d0
10210 C and vector conecting the side-chain with its proper calfa
10211       side_calf(j)=c(j,k+nres)-c(j,k)
10212 C      side_calf(j)=2.0d0
10213       pept_group(j)=c(j,i)-c(j,i+1)
10214 C lets have their lenght
10215       dist_pep_side=pep_side(j)**2+dist_pep_side
10216       dist_side_calf=dist_side_calf+side_calf(j)**2
10217       dist_pept_group=dist_pept_group+pept_group(j)**2
10218       enddo
10219        dist_pep_side=dsqrt(dist_pep_side)
10220        dist_pept_group=dsqrt(dist_pept_group)
10221        dist_side_calf=dsqrt(dist_side_calf)
10222       do j=1,3
10223         pep_side_norm(j)=pep_side(j)/dist_pep_side
10224         side_calf_norm(j)=dist_side_calf
10225       enddo
10226 C now sscale fraction
10227        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10228 C       print *,buff_shield,"buff"
10229 C now sscale
10230         if (sh_frac_dist.le.0.0) cycle
10231 C If we reach here it means that this side chain reaches the shielding sphere
10232 C Lets add him to the list for gradient
10233         ishield_list(i)=ishield_list(i)+1
10234 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10235 C this list is essential otherwise problem would be O3
10236         shield_list(ishield_list(i),i)=k
10237 C Lets have the sscale value
10238         if (sh_frac_dist.gt.1.0) then
10239          scale_fac_dist=1.0d0
10240          do j=1,3
10241          sh_frac_dist_grad(j)=0.0d0
10242          enddo
10243         else
10244          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10245      &                   *(2.0d0*sh_frac_dist-3.0d0)
10246          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10247      &                  /dist_pep_side/buff_shield*0.5d0
10248 C remember for the final gradient multiply sh_frac_dist_grad(j)
10249 C for side_chain by factor -2 !
10250          do j=1,3
10251          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10252 C         sh_frac_dist_grad(j)=0.0d0
10253 C         scale_fac_dist=1.0d0
10254 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10255 C     &                    sh_frac_dist_grad(j)
10256          enddo
10257         endif
10258 C this is what is now we have the distance scaling now volume...
10259       short=short_r_sidechain(itype(k))
10260       long=long_r_sidechain(itype(k))
10261       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10262       sinthet=short/dist_pep_side*costhet
10263 C now costhet_grad
10264 C       costhet=0.6d0
10265 C       sinthet=0.8
10266        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10267 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10268 C     &             -short/dist_pep_side**2/costhet)
10269 C       costhet_fac=0.0d0
10270        do j=1,3
10271          costhet_grad(j)=costhet_fac*pep_side(j)
10272        enddo
10273 C remember for the final gradient multiply costhet_grad(j)
10274 C for side_chain by factor -2 !
10275 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10276 C pep_side0pept_group is vector multiplication
10277       pep_side0pept_group=0.0d0
10278       do j=1,3
10279       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10280       enddo
10281       cosalfa=(pep_side0pept_group/
10282      & (dist_pep_side*dist_side_calf))
10283       fac_alfa_sin=1.0d0-cosalfa**2
10284       fac_alfa_sin=dsqrt(fac_alfa_sin)
10285       rkprim=fac_alfa_sin*(long-short)+short
10286 C      rkprim=short
10287
10288 C now costhet_grad
10289        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10290 C       cosphi=0.6
10291        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10292        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10293      &      dist_pep_side**2)
10294 C       sinphi=0.8
10295        do j=1,3
10296          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10297      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10298      &*(long-short)/fac_alfa_sin*cosalfa/
10299      &((dist_pep_side*dist_side_calf))*
10300      &((side_calf(j))-cosalfa*
10301      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10302 C       cosphi_grad_long(j)=0.0d0
10303         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10304      &*(long-short)/fac_alfa_sin*cosalfa
10305      &/((dist_pep_side*dist_side_calf))*
10306      &(pep_side(j)-
10307      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10308 C       cosphi_grad_loc(j)=0.0d0
10309        enddo
10310 C      print *,sinphi,sinthet
10311       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10312      &                    /VSolvSphere_div
10313 C     &                    *wshield
10314 C now the gradient...
10315       do j=1,3
10316       grad_shield(j,i)=grad_shield(j,i)
10317 C gradient po skalowaniu
10318      &                +(sh_frac_dist_grad(j)*VofOverlap
10319 C  gradient po costhet
10320      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10321      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10322      &       sinphi/sinthet*costhet*costhet_grad(j)
10323      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10324      & )*wshield
10325 C grad_shield_side is Cbeta sidechain gradient
10326       grad_shield_side(j,ishield_list(i),i)=
10327      &        (sh_frac_dist_grad(j)*(-2.0d0)
10328      &        *VofOverlap
10329      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10330      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10331      &       sinphi/sinthet*costhet*costhet_grad(j)
10332      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10333      &       )*wshield
10334
10335        grad_shield_loc(j,ishield_list(i),i)=
10336      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10337      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10338      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10339      &        ))
10340      &        *wshield
10341       enddo
10342       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10343       enddo
10344       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10345 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10346 c     &  " wshield",wshield
10347 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10348       enddo
10349       return
10350       end
10351 C--------------------------------------------------------------------------
10352       double precision function tschebyshev(m,n,x,y)
10353       implicit none
10354       include "DIMENSIONS"
10355       integer i,m,n
10356       double precision x(n),y,yy(0:maxvar),aux
10357 c Tschebyshev polynomial. Note that the first term is omitted
10358 c m=0: the constant term is included
10359 c m=1: the constant term is not included
10360       yy(0)=1.0d0
10361       yy(1)=y
10362       do i=2,n
10363         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10364       enddo
10365       aux=0.0d0
10366       do i=m,n
10367         aux=aux+x(i)*yy(i)
10368       enddo
10369       tschebyshev=aux
10370       return
10371       end
10372 C--------------------------------------------------------------------------
10373       double precision function gradtschebyshev(m,n,x,y)
10374       implicit none
10375       include "DIMENSIONS"
10376       integer i,m,n
10377       double precision x(n+1),y,yy(0:maxvar),aux
10378 c Tschebyshev polynomial. Note that the first term is omitted
10379 c m=0: the constant term is included
10380 c m=1: the constant term is not included
10381       yy(0)=1.0d0
10382       yy(1)=2.0d0*y
10383       do i=2,n
10384         yy(i)=2*y*yy(i-1)-yy(i-2)
10385       enddo
10386       aux=0.0d0
10387       do i=m,n
10388         aux=aux+x(i+1)*yy(i)*(i+1)
10389 C        print *, x(i+1),yy(i),i
10390       enddo
10391       gradtschebyshev=aux
10392       return
10393       end
10394 c----------------------------------------------------------------------------
10395       double precision function sscale2(r,r_cut,r0,rlamb)
10396       implicit none
10397       double precision r,gamm,r_cut,r0,rlamb,rr
10398       rr = dabs(r-r0)
10399 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10400 c      write (2,*) "rr",rr
10401       if(rr.lt.r_cut-rlamb) then
10402         sscale2=1.0d0
10403       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10404         gamm=(rr-(r_cut-rlamb))/rlamb
10405         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10406       else
10407         sscale2=0d0
10408       endif
10409       return
10410       end
10411 C-----------------------------------------------------------------------
10412       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10413       implicit none
10414       double precision r,gamm,r_cut,r0,rlamb,rr
10415       rr = dabs(r-r0)
10416       if(rr.lt.r_cut-rlamb) then
10417         sscalgrad2=0.0d0
10418       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10419         gamm=(rr-(r_cut-rlamb))/rlamb
10420         if (r.ge.r0) then
10421           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10422         else
10423           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10424         endif
10425       else
10426         sscalgrad2=0.0d0
10427       endif
10428       return
10429       end
10430 c----------------------------------------------------------------------------
10431       subroutine e_saxs(Esaxs_constr)
10432       implicit none
10433       include 'DIMENSIONS'
10434       include 'DIMENSIONS.ZSCOPT'
10435       include 'DIMENSIONS.FREE'
10436 #ifdef MPI
10437       include "mpif.h"
10438       include "COMMON.SETUP"
10439       integer IERR
10440 #endif
10441       include 'COMMON.SBRIDGE'
10442       include 'COMMON.CHAIN'
10443       include 'COMMON.GEO'
10444       include 'COMMON.LOCAL'
10445       include 'COMMON.INTERACT'
10446       include 'COMMON.VAR'
10447       include 'COMMON.IOUNITS'
10448       include 'COMMON.DERIV'
10449       include 'COMMON.CONTROL'
10450       include 'COMMON.NAMES'
10451       include 'COMMON.FFIELD'
10452       include 'COMMON.LANGEVIN'
10453       include 'COMMON.SAXS'
10454 c
10455       double precision Esaxs_constr
10456       integer i,iint,j,k,l
10457       double precision PgradC(maxSAXS,3,maxres),
10458      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10459 #ifdef MPI
10460       double precision PgradC_(maxSAXS,3,maxres),
10461      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10462 #endif
10463       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10464      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10465      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10466      & auxX,auxX1,CACAgrad,Cnorm
10467       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10468       double precision dist
10469       external dist
10470 c  SAXS restraint penalty function
10471 #ifdef DEBUG
10472       write(iout,*) "------- SAXS penalty function start -------"
10473       write (iout,*) "nsaxs",nsaxs
10474       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10475       write (iout,*) "Psaxs"
10476       do i=1,nsaxs
10477         write (iout,'(i5,e15.5)') i, Psaxs(i)
10478       enddo
10479 #endif
10480       Esaxs_constr = 0.0d0
10481       do k=1,nsaxs
10482         Pcalc(k)=0.0d0
10483         do j=1,nres
10484           do l=1,3
10485             PgradC(k,l,j)=0.0d0
10486             PgradX(k,l,j)=0.0d0
10487           enddo
10488         enddo
10489       enddo
10490       do i=iatsc_s,iatsc_e
10491        if (itype(i).eq.ntyp1) cycle
10492        do iint=1,nint_gr(i)
10493          do j=istart(i,iint),iend(i,iint)
10494            if (itype(j).eq.ntyp1) cycle
10495 #ifdef ALLSAXS
10496            dijCACA=dist(i,j)
10497            dijCASC=dist(i,j+nres)
10498            dijSCCA=dist(i+nres,j)
10499            dijSCSC=dist(i+nres,j+nres)
10500            sigma2CACA=2.0d0/(pstok**2)
10501            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10502            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10503            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10504            do k=1,nsaxs
10505              dk = distsaxs(k)
10506              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10507              if (itype(j).ne.10) then
10508              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10509              else
10510              endif
10511              expCASC = 0.0d0
10512              if (itype(i).ne.10) then
10513              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10514              else
10515              expSCCA = 0.0d0
10516              endif
10517              if (itype(i).ne.10 .and. itype(j).ne.10) then
10518              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10519              else
10520              expSCSC = 0.0d0
10521              endif
10522              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10523 #ifdef DEBUG
10524              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10525 #endif
10526              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10527              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10528              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10529              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10530              do l=1,3
10531 c CA CA
10532                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10533                PgradC(k,l,i) = PgradC(k,l,i)-aux
10534                PgradC(k,l,j) = PgradC(k,l,j)+aux
10535 c CA SC
10536                if (itype(j).ne.10) then
10537                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10538                PgradC(k,l,i) = PgradC(k,l,i)-aux
10539                PgradC(k,l,j) = PgradC(k,l,j)+aux
10540                PgradX(k,l,j) = PgradX(k,l,j)+aux
10541                endif
10542 c SC CA
10543                if (itype(i).ne.10) then
10544                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10545                PgradX(k,l,i) = PgradX(k,l,i)-aux
10546                PgradC(k,l,i) = PgradC(k,l,i)-aux
10547                PgradC(k,l,j) = PgradC(k,l,j)+aux
10548                endif
10549 c SC SC
10550                if (itype(i).ne.10 .and. itype(j).ne.10) then
10551                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10552                PgradC(k,l,i) = PgradC(k,l,i)-aux
10553                PgradC(k,l,j) = PgradC(k,l,j)+aux
10554                PgradX(k,l,i) = PgradX(k,l,i)-aux
10555                PgradX(k,l,j) = PgradX(k,l,j)+aux
10556                endif
10557              enddo ! l
10558            enddo ! k
10559 #else
10560            dijCACA=dist(i,j)
10561            sigma2CACA=scal_rad**2*0.25d0/
10562      &        (restok(itype(j))**2+restok(itype(i))**2)
10563
10564            IF (saxs_cutoff.eq.0) THEN
10565            do k=1,nsaxs
10566              dk = distsaxs(k)
10567              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10568              Pcalc(k) = Pcalc(k)+expCACA
10569              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10570              do l=1,3
10571                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10572                PgradC(k,l,i) = PgradC(k,l,i)-aux
10573                PgradC(k,l,j) = PgradC(k,l,j)+aux
10574              enddo ! l
10575            enddo ! k
10576            ELSE
10577            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10578            do k=1,nsaxs
10579              dk = distsaxs(k)
10580 c             write (2,*) "ijk",i,j,k
10581              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10582              if (sss2.eq.0.0d0) cycle
10583              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10584              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10585              Pcalc(k) = Pcalc(k)+expCACA
10586 #ifdef DEBUG
10587              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10588 #endif
10589              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10590      &             ssgrad2*expCACA/sss2
10591              do l=1,3
10592 c CA CA
10593                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10594                PgradC(k,l,i) = PgradC(k,l,i)+aux
10595                PgradC(k,l,j) = PgradC(k,l,j)-aux
10596              enddo ! l
10597            enddo ! k
10598            ENDIF
10599 #endif
10600          enddo ! j
10601        enddo ! iint
10602       enddo ! i
10603 #ifdef MPI
10604       if (nfgtasks.gt.1) then
10605         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10606      &    MPI_SUM,king,FG_COMM,IERR)
10607         if (fg_rank.eq.king) then
10608           do k=1,nsaxs
10609             Pcalc(k) = Pcalc_(k)
10610           enddo
10611         endif
10612         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10613      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10614         if (fg_rank.eq.king) then
10615           do i=1,nres
10616             do l=1,3
10617               do k=1,nsaxs
10618                 PgradC(k,l,i) = PgradC_(k,l,i)
10619               enddo
10620             enddo
10621           enddo
10622         endif
10623 #ifdef ALLSAXS
10624         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*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               do k=1,nsaxs
10630                 PgradX(k,l,i) = PgradX_(k,l,i)
10631               enddo
10632             enddo
10633           enddo
10634         endif
10635 #endif
10636       endif
10637 #endif
10638 #ifdef MPI
10639       if (fg_rank.eq.king) then
10640 #endif
10641       Cnorm = 0.0d0
10642       do k=1,nsaxs
10643         Cnorm = Cnorm + Pcalc(k)
10644       enddo
10645       Esaxs_constr = dlog(Cnorm)-wsaxs0
10646       do k=1,nsaxs
10647         if (Pcalc(k).gt.0.0d0)
10648      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10649 #ifdef DEBUG
10650         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10651 #endif
10652       enddo
10653 #ifdef DEBUG
10654       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10655 #endif
10656       do i=nnt,nct
10657         do l=1,3
10658           auxC=0.0d0
10659           auxC1=0.0d0
10660           auxX=0.0d0
10661           auxX1=0.d0
10662           do k=1,nsaxs
10663             if (Pcalc(k).gt.0)
10664      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10665             auxC1 = auxC1+PgradC(k,l,i)
10666 #ifdef ALLSAXS
10667             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10668             auxX1 = auxX1+PgradX(k,l,i)
10669 #endif
10670           enddo
10671           gsaxsC(l,i) = auxC - auxC1/Cnorm
10672 #ifdef ALLSAXS
10673           gsaxsX(l,i) = auxX - auxX1/Cnorm
10674 #endif
10675 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10676 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10677         enddo
10678       enddo
10679 #ifdef MPI
10680       endif
10681 #endif
10682       return
10683       end
10684 c----------------------------------------------------------------------------
10685       subroutine e_saxsC(Esaxs_constr)
10686       implicit none
10687       include 'DIMENSIONS'
10688       include 'DIMENSIONS.ZSCOPT'
10689       include 'DIMENSIONS.FREE'
10690 #ifdef MPI
10691       include "mpif.h"
10692       include "COMMON.SETUP"
10693       integer IERR
10694 #endif
10695       include 'COMMON.SBRIDGE'
10696       include 'COMMON.CHAIN'
10697       include 'COMMON.GEO'
10698       include 'COMMON.LOCAL'
10699       include 'COMMON.INTERACT'
10700       include 'COMMON.VAR'
10701       include 'COMMON.IOUNITS'
10702       include 'COMMON.DERIV'
10703       include 'COMMON.CONTROL'
10704       include 'COMMON.NAMES'
10705       include 'COMMON.FFIELD'
10706       include 'COMMON.LANGEVIN'
10707       include 'COMMON.SAXS'
10708 c
10709       double precision Esaxs_constr
10710       integer i,iint,j,k,l
10711       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10712 #ifdef MPI
10713       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10714 #endif
10715       double precision dk,dijCASPH,dijSCSPH,
10716      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10717      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10718      & auxX,auxX1,Cnorm
10719 c  SAXS restraint penalty function
10720 #ifdef DEBUG
10721       write(iout,*) "------- SAXS penalty function start -------"
10722       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10723      & " isaxs_end",isaxs_end
10724       write (iout,*) "nnt",nnt," ntc",nct
10725       do i=nnt,nct
10726         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10727      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10728       enddo
10729       do i=nnt,nct
10730         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10731       enddo
10732 #endif
10733       Esaxs_constr = 0.0d0
10734       logPtot=0.0d0
10735       do j=isaxs_start,isaxs_end
10736         Pcalc=0.0d0
10737         do i=1,nres
10738           do l=1,3
10739             PgradC(l,i)=0.0d0
10740             PgradX(l,i)=0.0d0
10741           enddo
10742         enddo
10743         do i=nnt,nct
10744           dijCASPH=0.0d0
10745           dijSCSPH=0.0d0
10746           do l=1,3
10747             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10748           enddo
10749           if (itype(i).ne.10) then
10750           do l=1,3
10751             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10752           enddo
10753           endif
10754           sigma2CA=2.0d0/pstok**2
10755           sigma2SC=4.0d0/restok(itype(i))**2
10756           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10757           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10758           Pcalc = Pcalc+expCASPH+expSCSPH
10759 #ifdef DEBUG
10760           write(*,*) "processor i j Pcalc",
10761      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10762 #endif
10763           CASPHgrad = sigma2CA*expCASPH
10764           SCSPHgrad = sigma2SC*expSCSPH
10765           do l=1,3
10766             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10767             PgradX(l,i) = PgradX(l,i) + aux
10768             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10769           enddo ! l
10770         enddo ! i
10771         do i=nnt,nct
10772           do l=1,3
10773             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10774             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10775           enddo
10776         enddo
10777         logPtot = logPtot - dlog(Pcalc)
10778 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10779 c     &    " logPtot",logPtot
10780       enddo ! j
10781 #ifdef MPI
10782       if (nfgtasks.gt.1) then
10783 c        write (iout,*) "logPtot before reduction",logPtot
10784         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10785      &    MPI_SUM,king,FG_COMM,IERR)
10786         logPtot = logPtot_
10787 c        write (iout,*) "logPtot after reduction",logPtot
10788         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10789      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10790         if (fg_rank.eq.king) then
10791           do i=1,nres
10792             do l=1,3
10793               gsaxsC(l,i) = gsaxsC_(l,i)
10794             enddo
10795           enddo
10796         endif
10797         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10798      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10799         if (fg_rank.eq.king) then
10800           do i=1,nres
10801             do l=1,3
10802               gsaxsX(l,i) = gsaxsX_(l,i)
10803             enddo
10804           enddo
10805         endif
10806       endif
10807 #endif
10808       Esaxs_constr = logPtot
10809       return
10810       end
10811