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          do kk=1,constr_homology
4613           if(l_homo(kk,ii)) then
4614             min_odl=distancek(kk)
4615             exit
4616           endif
4617          enddo
4618          do kk=1,constr_homology
4619           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4620      &              min_odl=distancek(kk)
4621          enddo
4622 c        write (iout,* )"min_odl",min_odl
4623 #ifdef DEBUG
4624          write (iout,*) "ij dij",i,j,dij
4625          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4626          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4627          write (iout,* )"min_odl",min_odl
4628 #endif
4629 #ifdef OLDRESTR
4630          odleg2=0.0d0
4631 #else
4632          if (waga_dist.ge.0.0d0) then
4633            odleg2=nexl
4634          else
4635            odleg2=0.0d0
4636          endif
4637 #endif
4638          do k=1,constr_homology
4639 c Nie wiem po co to liczycie jeszcze raz!
4640 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4641 c     &              (2*(sigma_odl(i,j,k))**2))
4642            if(.not.l_homo(k,ii)) cycle
4643            if (waga_dist.ge.0.0d0) then
4644 c
4645 c          For Gaussian-type Urestr
4646 c
4647             godl(k)=dexp(-distancek(k)+min_odl)
4648             odleg2=odleg2+godl(k)
4649 c
4650 c          For Lorentzian-type Urestr
4651 c
4652            else
4653             odleg2=odleg2+distancek(k)
4654            endif
4655
4656 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4657 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4658 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4659 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4660
4661          enddo
4662 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4663 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4664 #ifdef DEBUG
4665          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4666          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4667 #endif
4668            if (waga_dist.ge.0.0d0) then
4669 c
4670 c          For Gaussian-type Urestr
4671 c
4672               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4673 c
4674 c          For Lorentzian-type Urestr
4675 c
4676            else
4677               odleg=odleg+odleg2/constr_homology
4678            endif
4679 c
4680 #ifdef GRAD
4681 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4682 c Gradient
4683 c
4684 c          For Gaussian-type Urestr
4685 c
4686          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4687          sum_sgodl=0.0d0
4688          do k=1,constr_homology
4689 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4690 c     &           *waga_dist)+min_odl
4691 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4692 c
4693          if(.not.l_homo(k,ii)) cycle
4694          if (waga_dist.ge.0.0d0) then
4695 c          For Gaussian-type Urestr
4696 c
4697            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4698 c
4699 c          For Lorentzian-type Urestr
4700 c
4701          else
4702            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4703      &           sigma_odlir(k,ii)**2)**2)
4704          endif
4705            sum_sgodl=sum_sgodl+sgodl
4706
4707 c            sgodl2=sgodl2+sgodl
4708 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4709 c      write(iout,*) "constr_homology=",constr_homology
4710 c      write(iout,*) i, j, k, "TEST K"
4711          enddo
4712          if (waga_dist.ge.0.0d0) then
4713 c
4714 c          For Gaussian-type Urestr
4715 c
4716             grad_odl3=waga_homology(iset)*waga_dist
4717      &                *sum_sgodl/(sum_godl*dij)
4718 c
4719 c          For Lorentzian-type Urestr
4720 c
4721          else
4722 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4723 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4724             grad_odl3=-waga_homology(iset)*waga_dist*
4725      &                sum_sgodl/(constr_homology*dij)
4726          endif
4727 c
4728 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4729
4730
4731 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4732 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4733 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4734
4735 ccc      write(iout,*) godl, sgodl, grad_odl3
4736
4737 c          grad_odl=grad_odl+grad_odl3
4738
4739          do jik=1,3
4740             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4741 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4742 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4743 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4744             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4745             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4746 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4747 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4748 c         if (i.eq.25.and.j.eq.27) then
4749 c         write(iout,*) "jik",jik,"i",i,"j",j
4750 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4751 c         write(iout,*) "grad_odl3",grad_odl3
4752 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4753 c         write(iout,*) "ggodl",ggodl
4754 c         write(iout,*) "ghpbc(",jik,i,")",
4755 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4756 c     &                 ghpbc(jik,j)
4757 c         endif
4758          enddo
4759 #endif
4760 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4761 ccc     & dLOG(odleg2),"-odleg=", -odleg
4762
4763       enddo ! ii-loop for dist
4764 #ifdef DEBUG
4765       write(iout,*) "------- dist restrs end -------"
4766 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4767 c    &     waga_d.eq.1.0d0) call sum_gradient
4768 #endif
4769 c Pseudo-energy and gradient from dihedral-angle restraints from
4770 c homology templates
4771 c      write (iout,*) "End of distance loop"
4772 c      call flush(iout)
4773       kat=0.0d0
4774 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4775 #ifdef DEBUG
4776       write(iout,*) "------- dih restrs start -------"
4777       do i=idihconstr_start_homo,idihconstr_end_homo
4778         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4779       enddo
4780 #endif
4781       do i=idihconstr_start_homo,idihconstr_end_homo
4782         kat2=0.0d0
4783 c        betai=beta(i,i+1,i+2,i+3)
4784         betai = phi(i)
4785 c       write (iout,*) "betai =",betai
4786         do k=1,constr_homology
4787           dih_diff(k)=pinorm(dih(k,i)-betai)
4788 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4789 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4790 c     &                                   -(6.28318-dih_diff(i,k))
4791 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4792 c     &                                   6.28318+dih_diff(i,k)
4793 #ifdef OLD_DIHED
4794           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4795 #else
4796           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4797 #endif
4798 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4799           gdih(k)=dexp(kat3)
4800           kat2=kat2+gdih(k)
4801 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4802 c          write(*,*)""
4803         enddo
4804 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4805 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4806 #ifdef DEBUG
4807         write (iout,*) "i",i," betai",betai," kat2",kat2
4808         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4809 #endif
4810         if (kat2.le.1.0d-14) cycle
4811         kat=kat-dLOG(kat2/constr_homology)
4812 c       write (iout,*) "kat",kat ! sum of -ln-s
4813
4814 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4815 ccc     & dLOG(kat2), "-kat=", -kat
4816
4817 #ifdef GRAD
4818 c ----------------------------------------------------------------------
4819 c Gradient
4820 c ----------------------------------------------------------------------
4821
4822         sum_gdih=kat2
4823         sum_sgdih=0.0d0
4824         do k=1,constr_homology
4825 #ifdef OLD_DIHED
4826           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4827 #else
4828           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4829 #endif
4830 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4831           sum_sgdih=sum_sgdih+sgdih
4832         enddo
4833 c       grad_dih3=sum_sgdih/sum_gdih
4834         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4835
4836 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4837 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4838 ccc     & gloc(nphi+i-3,icg)
4839         gloc(i,icg)=gloc(i,icg)+grad_dih3
4840 c        if (i.eq.25) then
4841 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4842 c        endif
4843 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4844 ccc     & gloc(nphi+i-3,icg)
4845 #endif
4846       enddo ! i-loop for dih
4847 #ifdef DEBUG
4848       write(iout,*) "------- dih restrs end -------"
4849 #endif
4850
4851 c Pseudo-energy and gradient for theta angle restraints from
4852 c homology templates
4853 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4854 c adapted
4855
4856 c
4857 c     For constr_homology reference structures (FP)
4858 c
4859 c     Uconst_back_tot=0.0d0
4860       Eval=0.0d0
4861       Erot=0.0d0
4862 c     Econstr_back legacy
4863 #ifdef GRAD
4864       do i=1,nres
4865 c     do i=ithet_start,ithet_end
4866        dutheta(i)=0.0d0
4867 c     enddo
4868 c     do i=loc_start,loc_end
4869         do j=1,3
4870           duscdiff(j,i)=0.0d0
4871           duscdiffx(j,i)=0.0d0
4872         enddo
4873       enddo
4874 #endif
4875 c
4876 c     do iref=1,nref
4877 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4878 c     write (iout,*) "waga_theta",waga_theta
4879       if (waga_theta.gt.0.0d0) then
4880 #ifdef DEBUG
4881       write (iout,*) "usampl",usampl
4882       write(iout,*) "------- theta restrs start -------"
4883 c     do i=ithet_start,ithet_end
4884 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4885 c     enddo
4886 #endif
4887 c     write (iout,*) "maxres",maxres,"nres",nres
4888
4889       do i=ithet_start,ithet_end
4890 c
4891 c     do i=1,nfrag_back
4892 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4893 c
4894 c Deviation of theta angles wrt constr_homology ref structures
4895 c
4896         utheta_i=0.0d0 ! argument of Gaussian for single k
4897         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4898 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4899 c       over residues in a fragment
4900 c       write (iout,*) "theta(",i,")=",theta(i)
4901         do k=1,constr_homology
4902 c
4903 c         dtheta_i=theta(j)-thetaref(j,iref)
4904 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4905           theta_diff(k)=thetatpl(k,i)-theta(i)
4906 c
4907           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4908 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4909           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4910           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4911 c         Gradient for single Gaussian restraint in subr Econstr_back
4912 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4913 c
4914         enddo
4915 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4916 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4917
4918 c
4919 #ifdef GRAD
4920 c         Gradient for multiple Gaussian restraint
4921         sum_gtheta=gutheta_i
4922         sum_sgtheta=0.0d0
4923         do k=1,constr_homology
4924 c        New generalized expr for multiple Gaussian from Econstr_back
4925          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4926 c
4927 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4928           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4929         enddo
4930 c
4931 c       Final value of gradient using same var as in Econstr_back
4932         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4933      &               *waga_homology(iset)
4934 c       dutheta(i)=sum_sgtheta/sum_gtheta
4935 c
4936 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4937 #endif
4938         Eval=Eval-dLOG(gutheta_i/constr_homology)
4939 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4940 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4941 c       Uconst_back=Uconst_back+utheta(i)
4942       enddo ! (i-loop for theta)
4943 #ifdef DEBUG
4944       write(iout,*) "------- theta restrs end -------"
4945 #endif
4946       endif
4947 c
4948 c Deviation of local SC geometry
4949 c
4950 c Separation of two i-loops (instructed by AL - 11/3/2014)
4951 c
4952 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4953 c     write (iout,*) "waga_d",waga_d
4954
4955 #ifdef DEBUG
4956       write(iout,*) "------- SC restrs start -------"
4957       write (iout,*) "Initial duscdiff,duscdiffx"
4958       do i=loc_start,loc_end
4959         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4960      &                 (duscdiffx(jik,i),jik=1,3)
4961       enddo
4962 #endif
4963       do i=loc_start,loc_end
4964         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4965         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4966 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4967 c       write(iout,*) "xxtab, yytab, zztab"
4968 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4969         do k=1,constr_homology
4970 c
4971           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4972 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4973           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4974           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4975 c         write(iout,*) "dxx, dyy, dzz"
4976 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4977 c
4978           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4979 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4980 c         uscdiffk(k)=usc_diff(i)
4981           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4982           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4983 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4984 c     &      xxref(j),yyref(j),zzref(j)
4985         enddo
4986 c
4987 c       Gradient
4988 c
4989 c       Generalized expression for multiple Gaussian acc to that for a single
4990 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4991 c
4992 c       Original implementation
4993 c       sum_guscdiff=guscdiff(i)
4994 c
4995 c       sum_sguscdiff=0.0d0
4996 c       do k=1,constr_homology
4997 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4998 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4999 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
5000 c       enddo
5001 c
5002 c       Implementation of new expressions for gradient (Jan. 2015)
5003 c
5004 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
5005 #ifdef GRAD
5006         do k=1,constr_homology
5007 c
5008 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
5009 c       before. Now the drivatives should be correct
5010 c
5011           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
5012 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
5013           dyy=-yytpl(k,i)+yytab(i) ! ibid y
5014           dzz=-zztpl(k,i)+zztab(i) ! ibid z
5015 c
5016 c         New implementation
5017 c
5018           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
5019      &                 sigma_d(k,i) ! for the grad wrt r'
5020 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
5021 c
5022 c
5023 c        New implementation
5024          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
5025          do jik=1,3
5026             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
5027      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
5028      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
5029             duscdiff(jik,i)=duscdiff(jik,i)+
5030      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
5031      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
5032             duscdiffx(jik,i)=duscdiffx(jik,i)+
5033      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
5034      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
5035 c
5036 #ifdef DEBUG
5037              write(iout,*) "jik",jik,"i",i
5038              write(iout,*) "dxx, dyy, dzz"
5039              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
5040              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
5041 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
5042 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
5043 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
5044 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
5045 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
5046 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
5047 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
5048 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
5049 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
5050 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
5051 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
5052 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
5053 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
5054 c            endif
5055 #endif
5056          enddo
5057         enddo
5058 #endif
5059 c
5060 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
5061 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
5062 c
5063 c        write (iout,*) i," uscdiff",uscdiff(i)
5064 c
5065 c Put together deviations from local geometry
5066
5067 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
5068 c      &            wfrag_back(3,i,iset)*uscdiff(i)
5069         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
5070 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
5071 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
5072 c       Uconst_back=Uconst_back+usc_diff(i)
5073 c
5074 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
5075 c
5076 c     New implment: multiplied by sum_sguscdiff
5077 c
5078
5079       enddo ! (i-loop for dscdiff)
5080
5081 c      endif
5082
5083 #ifdef DEBUG
5084       write(iout,*) "------- SC restrs end -------"
5085         write (iout,*) "------ After SC loop in e_modeller ------"
5086         do i=loc_start,loc_end
5087          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
5088          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
5089         enddo
5090       if (waga_theta.eq.1.0d0) then
5091       write (iout,*) "in e_modeller after SC restr end: dutheta"
5092       do i=ithet_start,ithet_end
5093         write (iout,*) i,dutheta(i)
5094       enddo
5095       endif
5096       if (waga_d.eq.1.0d0) then
5097       write (iout,*) "e_modeller after SC loop: duscdiff/x"
5098       do i=1,nres
5099         write (iout,*) i,(duscdiff(j,i),j=1,3)
5100         write (iout,*) i,(duscdiffx(j,i),j=1,3)
5101       enddo
5102       endif
5103 #endif
5104
5105 c Total energy from homology restraints
5106 #ifdef DEBUG
5107       write (iout,*) "odleg",odleg," kat",kat
5108       write (iout,*) "odleg",odleg," kat",kat
5109       write (iout,*) "Eval",Eval," Erot",Erot
5110       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
5111       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
5112       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
5113 #endif
5114 c
5115 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
5116 c
5117 c     ehomology_constr=odleg+kat
5118 c
5119 c     For Lorentzian-type Urestr
5120 c
5121
5122       if (waga_dist.ge.0.0d0) then
5123 c
5124 c          For Gaussian-type Urestr
5125 c
5126 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
5127 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5128         ehomology_constr=waga_dist*odleg+waga_angle*kat+
5129      &              waga_theta*Eval+waga_d*Erot
5130 c     write (iout,*) "ehomology_constr=",ehomology_constr
5131       else
5132 c
5133 c          For Lorentzian-type Urestr
5134 c
5135 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
5136 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
5137         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
5138      &              waga_theta*Eval+waga_d*Erot
5139 c     write (iout,*) "ehomology_constr=",ehomology_constr
5140       endif
5141 #ifdef DEBUG
5142       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
5143      & "Eval",waga_theta,eval,
5144      &   "Erot",waga_d,Erot
5145       write (iout,*) "ehomology_constr",ehomology_constr
5146 #endif
5147       return
5148
5149   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
5150   747 format(a12,i4,i4,i4,f8.3,f8.3)
5151   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
5152   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
5153   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
5154      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
5155       end
5156 c-----------------------------------------------------------------------
5157       subroutine ebond(estr)
5158 c
5159 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5160 c
5161       implicit real*8 (a-h,o-z)
5162       include 'DIMENSIONS'
5163       include 'DIMENSIONS.ZSCOPT'
5164       include 'COMMON.LOCAL'
5165       include 'COMMON.GEO'
5166       include 'COMMON.INTERACT'
5167       include 'COMMON.DERIV'
5168       include 'COMMON.VAR'
5169       include 'COMMON.CHAIN'
5170       include 'COMMON.IOUNITS'
5171       include 'COMMON.NAMES'
5172       include 'COMMON.FFIELD'
5173       include 'COMMON.CONTROL'
5174       double precision u(3),ud(3)
5175       estr=0.0d0
5176       estr1=0.0d0
5177 c      write (iout,*) "distchainmax",distchainmax
5178       do i=nnt+1,nct
5179 #ifdef FIVEDIAG
5180         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5181         diff = vbld(i)-vbldp0
5182 #else
5183         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5184 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5185 C          do j=1,3
5186 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5187 C     &      *dc(j,i-1)/vbld(i)
5188 C          enddo
5189 C          if (energy_dec) write(iout,*)
5190 C     &       "estr1",i,vbld(i),distchainmax,
5191 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5192 C        else
5193          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5194         diff = vbld(i)-vbldpDUM
5195 C         write(iout,*) i,diff
5196          else
5197           diff = vbld(i)-vbldp0
5198 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5199          endif
5200 #endif
5201           estr=estr+diff*diff
5202           do j=1,3
5203             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5204           enddo
5205 C        endif
5206           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5207      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5208       enddo
5209       estr=0.5d0*AKP*estr+estr1
5210 c
5211 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5212 c
5213       do i=nnt,nct
5214         iti=iabs(itype(i))
5215         if (iti.ne.10 .and. iti.ne.ntyp1) then
5216           nbi=nbondterm(iti)
5217           if (nbi.eq.1) then
5218             diff=vbld(i+nres)-vbldsc0(1,iti)
5219             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5220      &      vbldsc0(1,iti),diff,
5221      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5222             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5223             do j=1,3
5224               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5225             enddo
5226           else
5227             do j=1,nbi
5228               diff=vbld(i+nres)-vbldsc0(j,iti)
5229               ud(j)=aksc(j,iti)*diff
5230               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5231             enddo
5232             uprod=u(1)
5233             do j=2,nbi
5234               uprod=uprod*u(j)
5235             enddo
5236             usum=0.0d0
5237             usumsqder=0.0d0
5238             do j=1,nbi
5239               uprod1=1.0d0
5240               uprod2=1.0d0
5241               do k=1,nbi
5242                 if (k.ne.j) then
5243                   uprod1=uprod1*u(k)
5244                   uprod2=uprod2*u(k)*u(k)
5245                 endif
5246               enddo
5247               usum=usum+uprod1
5248               usumsqder=usumsqder+ud(j)*uprod2
5249             enddo
5250 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5251 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5252             estr=estr+uprod/usum
5253             do j=1,3
5254              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5255             enddo
5256           endif
5257         endif
5258       enddo
5259       return
5260       end
5261 #ifdef CRYST_THETA
5262 C--------------------------------------------------------------------------
5263       subroutine ebend(etheta,ethetacnstr)
5264 C
5265 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5266 C angles gamma and its derivatives in consecutive thetas and gammas.
5267 C
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'DIMENSIONS.ZSCOPT'
5271       include 'COMMON.LOCAL'
5272       include 'COMMON.GEO'
5273       include 'COMMON.INTERACT'
5274       include 'COMMON.DERIV'
5275       include 'COMMON.VAR'
5276       include 'COMMON.CHAIN'
5277       include 'COMMON.IOUNITS'
5278       include 'COMMON.NAMES'
5279       include 'COMMON.FFIELD'
5280       include 'COMMON.TORCNSTR'
5281       common /calcthet/ term1,term2,termm,diffak,ratak,
5282      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5283      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5284       double precision y(2),z(2)
5285       delta=0.02d0*pi
5286 c      time11=dexp(-2*time)
5287 c      time12=1.0d0
5288       etheta=0.0D0
5289 c      write (iout,*) "nres",nres
5290 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5291 c      write (iout,*) ithet_start,ithet_end
5292       do i=ithet_start,ithet_end
5293 C        if (itype(i-1).eq.ntyp1) cycle
5294         if (i.le.2) cycle
5295         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5296      &  .or.itype(i).eq.ntyp1) cycle
5297 C Zero the energy function and its derivative at 0 or pi.
5298         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5299         it=itype(i-1)
5300         ichir1=isign(1,itype(i-2))
5301         ichir2=isign(1,itype(i))
5302          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5303          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5304          if (itype(i-1).eq.10) then
5305           itype1=isign(10,itype(i-2))
5306           ichir11=isign(1,itype(i-2))
5307           ichir12=isign(1,itype(i-2))
5308           itype2=isign(10,itype(i))
5309           ichir21=isign(1,itype(i))
5310           ichir22=isign(1,itype(i))
5311          endif
5312          if (i.eq.3) then
5313           y(1)=0.0D0
5314           y(2)=0.0D0
5315           else
5316
5317         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5318 #ifdef OSF
5319           phii=phi(i)
5320 c          icrc=0
5321 c          call proc_proc(phii,icrc)
5322           if (icrc.eq.1) phii=150.0
5323 #else
5324           phii=phi(i)
5325 #endif
5326           y(1)=dcos(phii)
5327           y(2)=dsin(phii)
5328         else
5329           y(1)=0.0D0
5330           y(2)=0.0D0
5331         endif
5332         endif
5333         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5334 #ifdef OSF
5335           phii1=phi(i+1)
5336 c          icrc=0
5337 c          call proc_proc(phii1,icrc)
5338           if (icrc.eq.1) phii1=150.0
5339           phii1=pinorm(phii1)
5340           z(1)=cos(phii1)
5341 #else
5342           phii1=phi(i+1)
5343           z(1)=dcos(phii1)
5344 #endif
5345           z(2)=dsin(phii1)
5346         else
5347           z(1)=0.0D0
5348           z(2)=0.0D0
5349         endif
5350 C Calculate the "mean" value of theta from the part of the distribution
5351 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5352 C In following comments this theta will be referred to as t_c.
5353         thet_pred_mean=0.0d0
5354         do k=1,2
5355             athetk=athet(k,it,ichir1,ichir2)
5356             bthetk=bthet(k,it,ichir1,ichir2)
5357           if (it.eq.10) then
5358              athetk=athet(k,itype1,ichir11,ichir12)
5359              bthetk=bthet(k,itype2,ichir21,ichir22)
5360           endif
5361           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5362         enddo
5363 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5364         dthett=thet_pred_mean*ssd
5365         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5366 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5367 C Derivatives of the "mean" values in gamma1 and gamma2.
5368         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5369      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5370          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5371      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5372          if (it.eq.10) then
5373       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5374      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5375         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5376      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5377          endif
5378         if (theta(i).gt.pi-delta) then
5379           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5380      &         E_tc0)
5381           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5382           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5383           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5384      &        E_theta)
5385           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5386      &        E_tc)
5387         else if (theta(i).lt.delta) then
5388           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5389           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5390           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5391      &        E_theta)
5392           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5393           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5394      &        E_tc)
5395         else
5396           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5397      &        E_theta,E_tc)
5398         endif
5399         etheta=etheta+ethetai
5400 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5401 c     &      'ebend',i,ethetai,theta(i),itype(i)
5402 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5403 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5404         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5405         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5406         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5407 c 1215   continue
5408       enddo
5409       ethetacnstr=0.0d0
5410 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5411       do i=1,ntheta_constr
5412         itheta=itheta_constr(i)
5413         thetiii=theta(itheta)
5414         difi=pinorm(thetiii-theta_constr0(i))
5415         if (difi.gt.theta_drange(i)) then
5416           difi=difi-theta_drange(i)
5417           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5418           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5419      &    +for_thet_constr(i)*difi**3
5420         else if (difi.lt.-drange(i)) then
5421           difi=difi+drange(i)
5422           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5423           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5424      &    +for_thet_constr(i)*difi**3
5425         else
5426           difi=0.0
5427         endif
5428 C       if (energy_dec) then
5429 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5430 C     &    i,itheta,rad2deg*thetiii,
5431 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5432 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5433 C     &    gloc(itheta+nphi-2,icg)
5434 C        endif
5435       enddo
5436 C Ufff.... We've done all this!!!
5437       return
5438       end
5439 C---------------------------------------------------------------------------
5440       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5441      &     E_tc)
5442       implicit real*8 (a-h,o-z)
5443       include 'DIMENSIONS'
5444       include 'COMMON.LOCAL'
5445       include 'COMMON.IOUNITS'
5446       common /calcthet/ term1,term2,termm,diffak,ratak,
5447      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5448      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5449 C Calculate the contributions to both Gaussian lobes.
5450 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5451 C The "polynomial part" of the "standard deviation" of this part of
5452 C the distribution.
5453         sig=polthet(3,it)
5454         do j=2,0,-1
5455           sig=sig*thet_pred_mean+polthet(j,it)
5456         enddo
5457 C Derivative of the "interior part" of the "standard deviation of the"
5458 C gamma-dependent Gaussian lobe in t_c.
5459         sigtc=3*polthet(3,it)
5460         do j=2,1,-1
5461           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5462         enddo
5463         sigtc=sig*sigtc
5464 C Set the parameters of both Gaussian lobes of the distribution.
5465 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5466         fac=sig*sig+sigc0(it)
5467         sigcsq=fac+fac
5468         sigc=1.0D0/sigcsq
5469 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5470         sigsqtc=-4.0D0*sigcsq*sigtc
5471 c       print *,i,sig,sigtc,sigsqtc
5472 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5473         sigtc=-sigtc/(fac*fac)
5474 C Following variable is sigma(t_c)**(-2)
5475         sigcsq=sigcsq*sigcsq
5476         sig0i=sig0(it)
5477         sig0inv=1.0D0/sig0i**2
5478         delthec=thetai-thet_pred_mean
5479         delthe0=thetai-theta0i
5480         term1=-0.5D0*sigcsq*delthec*delthec
5481         term2=-0.5D0*sig0inv*delthe0*delthe0
5482 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5483 C NaNs in taking the logarithm. We extract the largest exponent which is added
5484 C to the energy (this being the log of the distribution) at the end of energy
5485 C term evaluation for this virtual-bond angle.
5486         if (term1.gt.term2) then
5487           termm=term1
5488           term2=dexp(term2-termm)
5489           term1=1.0d0
5490         else
5491           termm=term2
5492           term1=dexp(term1-termm)
5493           term2=1.0d0
5494         endif
5495 C The ratio between the gamma-independent and gamma-dependent lobes of
5496 C the distribution is a Gaussian function of thet_pred_mean too.
5497         diffak=gthet(2,it)-thet_pred_mean
5498         ratak=diffak/gthet(3,it)**2
5499         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5500 C Let's differentiate it in thet_pred_mean NOW.
5501         aktc=ak*ratak
5502 C Now put together the distribution terms to make complete distribution.
5503         termexp=term1+ak*term2
5504         termpre=sigc+ak*sig0i
5505 C Contribution of the bending energy from this theta is just the -log of
5506 C the sum of the contributions from the two lobes and the pre-exponential
5507 C factor. Simple enough, isn't it?
5508         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5509 C NOW the derivatives!!!
5510 C 6/6/97 Take into account the deformation.
5511         E_theta=(delthec*sigcsq*term1
5512      &       +ak*delthe0*sig0inv*term2)/termexp
5513         E_tc=((sigtc+aktc*sig0i)/termpre
5514      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5515      &       aktc*term2)/termexp)
5516       return
5517       end
5518 c-----------------------------------------------------------------------------
5519       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5520       implicit real*8 (a-h,o-z)
5521       include 'DIMENSIONS'
5522       include 'COMMON.LOCAL'
5523       include 'COMMON.IOUNITS'
5524       common /calcthet/ term1,term2,termm,diffak,ratak,
5525      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5526      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5527       delthec=thetai-thet_pred_mean
5528       delthe0=thetai-theta0i
5529 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5530       t3 = thetai-thet_pred_mean
5531       t6 = t3**2
5532       t9 = term1
5533       t12 = t3*sigcsq
5534       t14 = t12+t6*sigsqtc
5535       t16 = 1.0d0
5536       t21 = thetai-theta0i
5537       t23 = t21**2
5538       t26 = term2
5539       t27 = t21*t26
5540       t32 = termexp
5541       t40 = t32**2
5542       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5543      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5544      & *(-t12*t9-ak*sig0inv*t27)
5545       return
5546       end
5547 #else
5548 C--------------------------------------------------------------------------
5549       subroutine ebend(etheta)
5550 C
5551 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5552 C angles gamma and its derivatives in consecutive thetas and gammas.
5553 C ab initio-derived potentials from
5554 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5555 C
5556       implicit real*8 (a-h,o-z)
5557       include 'DIMENSIONS'
5558       include 'DIMENSIONS.ZSCOPT'
5559       include 'COMMON.LOCAL'
5560       include 'COMMON.GEO'
5561       include 'COMMON.INTERACT'
5562       include 'COMMON.DERIV'
5563       include 'COMMON.VAR'
5564       include 'COMMON.CHAIN'
5565       include 'COMMON.IOUNITS'
5566       include 'COMMON.NAMES'
5567       include 'COMMON.FFIELD'
5568       include 'COMMON.CONTROL'
5569       include 'COMMON.TORCNSTR'
5570       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5571      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5572      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5573      & sinph1ph2(maxdouble,maxdouble)
5574       logical lprn /.false./, lprn1 /.false./
5575       etheta=0.0D0
5576 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5577       do i=ithet_start,ithet_end
5578 C         if (i.eq.2) cycle
5579 C        if (itype(i-1).eq.ntyp1) cycle
5580         if (i.le.2) cycle
5581         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5582      &  .or.itype(i).eq.ntyp1) cycle
5583         if (iabs(itype(i+1)).eq.20) iblock=2
5584         if (iabs(itype(i+1)).ne.20) iblock=1
5585         dethetai=0.0d0
5586         dephii=0.0d0
5587         dephii1=0.0d0
5588         theti2=0.5d0*theta(i)
5589         ityp2=ithetyp((itype(i-1)))
5590         do k=1,nntheterm
5591           coskt(k)=dcos(k*theti2)
5592           sinkt(k)=dsin(k*theti2)
5593         enddo
5594 cu        if (i.eq.3) then
5595 cu          phii=0.0d0
5596 cu          ityp1=nthetyp+1
5597 cu          do k=1,nsingle
5598 cu            cosph1(k)=0.0d0
5599 cu            sinph1(k)=0.0d0
5600 cu          enddo
5601 cu        else
5602         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5603 #ifdef OSF
5604           phii=phi(i)
5605           if (phii.ne.phii) phii=150.0
5606 #else
5607           phii=phi(i)
5608 #endif
5609           ityp1=ithetyp((itype(i-2)))
5610           do k=1,nsingle
5611             cosph1(k)=dcos(k*phii)
5612             sinph1(k)=dsin(k*phii)
5613           enddo
5614         else
5615           phii=0.0d0
5616 c          ityp1=nthetyp+1
5617           do k=1,nsingle
5618             ityp1=ithetyp((itype(i-2)))
5619             cosph1(k)=0.0d0
5620             sinph1(k)=0.0d0
5621           enddo
5622         endif
5623         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5624 #ifdef OSF
5625           phii1=phi(i+1)
5626           if (phii1.ne.phii1) phii1=150.0
5627           phii1=pinorm(phii1)
5628 #else
5629           phii1=phi(i+1)
5630 #endif
5631           ityp3=ithetyp((itype(i)))
5632           do k=1,nsingle
5633             cosph2(k)=dcos(k*phii1)
5634             sinph2(k)=dsin(k*phii1)
5635           enddo
5636         else
5637           phii1=0.0d0
5638 c          ityp3=nthetyp+1
5639           ityp3=ithetyp((itype(i)))
5640           do k=1,nsingle
5641             cosph2(k)=0.0d0
5642             sinph2(k)=0.0d0
5643           enddo
5644         endif
5645 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5646 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5647 c        call flush(iout)
5648         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5649         do k=1,ndouble
5650           do l=1,k-1
5651             ccl=cosph1(l)*cosph2(k-l)
5652             ssl=sinph1(l)*sinph2(k-l)
5653             scl=sinph1(l)*cosph2(k-l)
5654             csl=cosph1(l)*sinph2(k-l)
5655             cosph1ph2(l,k)=ccl-ssl
5656             cosph1ph2(k,l)=ccl+ssl
5657             sinph1ph2(l,k)=scl+csl
5658             sinph1ph2(k,l)=scl-csl
5659           enddo
5660         enddo
5661         if (lprn) then
5662         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5663      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5664         write (iout,*) "coskt and sinkt"
5665         do k=1,nntheterm
5666           write (iout,*) k,coskt(k),sinkt(k)
5667         enddo
5668         endif
5669         do k=1,ntheterm
5670           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5671           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5672      &      *coskt(k)
5673           if (lprn)
5674      &    write (iout,*) "k",k,"
5675      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5676      &     " ethetai",ethetai
5677         enddo
5678         if (lprn) then
5679         write (iout,*) "cosph and sinph"
5680         do k=1,nsingle
5681           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5682         enddo
5683         write (iout,*) "cosph1ph2 and sinph2ph2"
5684         do k=2,ndouble
5685           do l=1,k-1
5686             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5687      &         sinph1ph2(l,k),sinph1ph2(k,l)
5688           enddo
5689         enddo
5690         write(iout,*) "ethetai",ethetai
5691         endif
5692         do m=1,ntheterm2
5693           do k=1,nsingle
5694             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5695      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5696      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5697      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5698             ethetai=ethetai+sinkt(m)*aux
5699             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5700             dephii=dephii+k*sinkt(m)*(
5701      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5702      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5703             dephii1=dephii1+k*sinkt(m)*(
5704      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5705      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5706             if (lprn)
5707      &      write (iout,*) "m",m," k",k," bbthet",
5708      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5709      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5710      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5711      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5712           enddo
5713         enddo
5714         if (lprn)
5715      &  write(iout,*) "ethetai",ethetai
5716         do m=1,ntheterm3
5717           do k=2,ndouble
5718             do l=1,k-1
5719               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5720      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5721      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5722      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5723               ethetai=ethetai+sinkt(m)*aux
5724               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5725               dephii=dephii+l*sinkt(m)*(
5726      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5727      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5728      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5729      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5730               dephii1=dephii1+(k-l)*sinkt(m)*(
5731      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5732      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5733      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5734      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5735               if (lprn) then
5736               write (iout,*) "m",m," k",k," l",l," ffthet",
5737      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5738      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5739      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5740      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5741      &            " ethetai",ethetai
5742               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5743      &            cosph1ph2(k,l)*sinkt(m),
5744      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5745               endif
5746             enddo
5747           enddo
5748         enddo
5749 10      continue
5750         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5751      &   i,theta(i)*rad2deg,phii*rad2deg,
5752      &   phii1*rad2deg,ethetai
5753         etheta=etheta+ethetai
5754         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5755         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5756 c        gloc(nphi+i-2,icg)=wang*dethetai
5757         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5758       enddo
5759       return
5760       end
5761 #endif
5762 #ifdef CRYST_SC
5763 c-----------------------------------------------------------------------------
5764       subroutine esc(escloc)
5765 C Calculate the local energy of a side chain and its derivatives in the
5766 C corresponding virtual-bond valence angles THETA and the spherical angles
5767 C ALPHA and OMEGA.
5768       implicit real*8 (a-h,o-z)
5769       include 'DIMENSIONS'
5770       include 'DIMENSIONS.ZSCOPT'
5771       include 'COMMON.GEO'
5772       include 'COMMON.LOCAL'
5773       include 'COMMON.VAR'
5774       include 'COMMON.INTERACT'
5775       include 'COMMON.DERIV'
5776       include 'COMMON.CHAIN'
5777       include 'COMMON.IOUNITS'
5778       include 'COMMON.NAMES'
5779       include 'COMMON.FFIELD'
5780       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5781      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5782       common /sccalc/ time11,time12,time112,theti,it,nlobit
5783       delta=0.02d0*pi
5784       escloc=0.0D0
5785 C      write (iout,*) 'ESC'
5786       do i=loc_start,loc_end
5787         it=itype(i)
5788         if (it.eq.ntyp1) cycle
5789         if (it.eq.10) goto 1
5790         nlobit=nlob(iabs(it))
5791 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5792 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5793         theti=theta(i+1)-pipol
5794         x(1)=dtan(theti)
5795         x(2)=alph(i)
5796         x(3)=omeg(i)
5797 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5798
5799         if (x(2).gt.pi-delta) then
5800           xtemp(1)=x(1)
5801           xtemp(2)=pi-delta
5802           xtemp(3)=x(3)
5803           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5804           xtemp(2)=pi
5805           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5806           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5807      &        escloci,dersc(2))
5808           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5809      &        ddersc0(1),dersc(1))
5810           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5811      &        ddersc0(3),dersc(3))
5812           xtemp(2)=pi-delta
5813           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5814           xtemp(2)=pi
5815           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5816           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5817      &            dersc0(2),esclocbi,dersc02)
5818           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5819      &            dersc12,dersc01)
5820           call splinthet(x(2),0.5d0*delta,ss,ssd)
5821           dersc0(1)=dersc01
5822           dersc0(2)=dersc02
5823           dersc0(3)=0.0d0
5824           do k=1,3
5825             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5826           enddo
5827           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5828           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5829      &             esclocbi,ss,ssd
5830           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5831 c         escloci=esclocbi
5832 c         write (iout,*) escloci
5833         else if (x(2).lt.delta) then
5834           xtemp(1)=x(1)
5835           xtemp(2)=delta
5836           xtemp(3)=x(3)
5837           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5838           xtemp(2)=0.0d0
5839           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5840           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5841      &        escloci,dersc(2))
5842           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5843      &        ddersc0(1),dersc(1))
5844           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5845      &        ddersc0(3),dersc(3))
5846           xtemp(2)=delta
5847           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5848           xtemp(2)=0.0d0
5849           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5850           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5851      &            dersc0(2),esclocbi,dersc02)
5852           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5853      &            dersc12,dersc01)
5854           dersc0(1)=dersc01
5855           dersc0(2)=dersc02
5856           dersc0(3)=0.0d0
5857           call splinthet(x(2),0.5d0*delta,ss,ssd)
5858           do k=1,3
5859             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5860           enddo
5861           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5862 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5863 c     &             esclocbi,ss,ssd
5864           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5865 C         write (iout,*) 'i=',i, escloci
5866         else
5867           call enesc(x,escloci,dersc,ddummy,.false.)
5868         endif
5869
5870         escloc=escloc+escloci
5871 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5872             write (iout,'(a6,i5,0pf7.3)')
5873      &     'escloc',i,escloci
5874
5875         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5876      &   wscloc*dersc(1)
5877         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5878         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5879     1   continue
5880       enddo
5881       return
5882       end
5883 C---------------------------------------------------------------------------
5884       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5885       implicit real*8 (a-h,o-z)
5886       include 'DIMENSIONS'
5887       include 'COMMON.GEO'
5888       include 'COMMON.LOCAL'
5889       include 'COMMON.IOUNITS'
5890       common /sccalc/ time11,time12,time112,theti,it,nlobit
5891       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5892       double precision contr(maxlob,-1:1)
5893       logical mixed
5894 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5895         escloc_i=0.0D0
5896         do j=1,3
5897           dersc(j)=0.0D0
5898           if (mixed) ddersc(j)=0.0d0
5899         enddo
5900         x3=x(3)
5901
5902 C Because of periodicity of the dependence of the SC energy in omega we have
5903 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5904 C To avoid underflows, first compute & store the exponents.
5905
5906         do iii=-1,1
5907
5908           x(3)=x3+iii*dwapi
5909
5910           do j=1,nlobit
5911             do k=1,3
5912               z(k)=x(k)-censc(k,j,it)
5913             enddo
5914             do k=1,3
5915               Axk=0.0D0
5916               do l=1,3
5917                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5918               enddo
5919               Ax(k,j,iii)=Axk
5920             enddo
5921             expfac=0.0D0
5922             do k=1,3
5923               expfac=expfac+Ax(k,j,iii)*z(k)
5924             enddo
5925             contr(j,iii)=expfac
5926           enddo ! j
5927
5928         enddo ! iii
5929
5930         x(3)=x3
5931 C As in the case of ebend, we want to avoid underflows in exponentiation and
5932 C subsequent NaNs and INFs in energy calculation.
5933 C Find the largest exponent
5934         emin=contr(1,-1)
5935         do iii=-1,1
5936           do j=1,nlobit
5937             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5938           enddo
5939         enddo
5940         emin=0.5D0*emin
5941 cd      print *,'it=',it,' emin=',emin
5942
5943 C Compute the contribution to SC energy and derivatives
5944         do iii=-1,1
5945
5946           do j=1,nlobit
5947             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5948 cd          print *,'j=',j,' expfac=',expfac
5949             escloc_i=escloc_i+expfac
5950             do k=1,3
5951               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5952             enddo
5953             if (mixed) then
5954               do k=1,3,2
5955                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5956      &            +gaussc(k,2,j,it))*expfac
5957               enddo
5958             endif
5959           enddo
5960
5961         enddo ! iii
5962
5963         dersc(1)=dersc(1)/cos(theti)**2
5964         ddersc(1)=ddersc(1)/cos(theti)**2
5965         ddersc(3)=ddersc(3)
5966
5967         escloci=-(dlog(escloc_i)-emin)
5968         do j=1,3
5969           dersc(j)=dersc(j)/escloc_i
5970         enddo
5971         if (mixed) then
5972           do j=1,3,2
5973             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5974           enddo
5975         endif
5976       return
5977       end
5978 C------------------------------------------------------------------------------
5979       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5980       implicit real*8 (a-h,o-z)
5981       include 'DIMENSIONS'
5982       include 'COMMON.GEO'
5983       include 'COMMON.LOCAL'
5984       include 'COMMON.IOUNITS'
5985       common /sccalc/ time11,time12,time112,theti,it,nlobit
5986       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5987       double precision contr(maxlob)
5988       logical mixed
5989
5990       escloc_i=0.0D0
5991
5992       do j=1,3
5993         dersc(j)=0.0D0
5994       enddo
5995
5996       do j=1,nlobit
5997         do k=1,2
5998           z(k)=x(k)-censc(k,j,it)
5999         enddo
6000         z(3)=dwapi
6001         do k=1,3
6002           Axk=0.0D0
6003           do l=1,3
6004             Axk=Axk+gaussc(l,k,j,it)*z(l)
6005           enddo
6006           Ax(k,j)=Axk
6007         enddo
6008         expfac=0.0D0
6009         do k=1,3
6010           expfac=expfac+Ax(k,j)*z(k)
6011         enddo
6012         contr(j)=expfac
6013       enddo ! j
6014
6015 C As in the case of ebend, we want to avoid underflows in exponentiation and
6016 C subsequent NaNs and INFs in energy calculation.
6017 C Find the largest exponent
6018       emin=contr(1)
6019       do j=1,nlobit
6020         if (emin.gt.contr(j)) emin=contr(j)
6021       enddo
6022       emin=0.5D0*emin
6023
6024 C Compute the contribution to SC energy and derivatives
6025
6026       dersc12=0.0d0
6027       do j=1,nlobit
6028         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6029         escloc_i=escloc_i+expfac
6030         do k=1,2
6031           dersc(k)=dersc(k)+Ax(k,j)*expfac
6032         enddo
6033         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6034      &            +gaussc(1,2,j,it))*expfac
6035         dersc(3)=0.0d0
6036       enddo
6037
6038       dersc(1)=dersc(1)/cos(theti)**2
6039       dersc12=dersc12/cos(theti)**2
6040       escloci=-(dlog(escloc_i)-emin)
6041       do j=1,2
6042         dersc(j)=dersc(j)/escloc_i
6043       enddo
6044       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6045       return
6046       end
6047 #else
6048 c----------------------------------------------------------------------------------
6049       subroutine esc(escloc)
6050 C Calculate the local energy of a side chain and its derivatives in the
6051 C corresponding virtual-bond valence angles THETA and the spherical angles
6052 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6053 C added by Urszula Kozlowska. 07/11/2007
6054 C
6055       implicit real*8 (a-h,o-z)
6056       include 'DIMENSIONS'
6057       include 'DIMENSIONS.ZSCOPT'
6058       include 'COMMON.GEO'
6059       include 'COMMON.LOCAL'
6060       include 'COMMON.VAR'
6061       include 'COMMON.SCROT'
6062       include 'COMMON.INTERACT'
6063       include 'COMMON.DERIV'
6064       include 'COMMON.CHAIN'
6065       include 'COMMON.IOUNITS'
6066       include 'COMMON.NAMES'
6067       include 'COMMON.FFIELD'
6068       include 'COMMON.CONTROL'
6069       include 'COMMON.VECTORS'
6070       double precision x_prime(3),y_prime(3),z_prime(3)
6071      &    , sumene,dsc_i,dp2_i,x(65),
6072      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6073      &    de_dxx,de_dyy,de_dzz,de_dt
6074       double precision s1_t,s1_6_t,s2_t,s2_6_t
6075       double precision
6076      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6077      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6078      & dt_dCi(3),dt_dCi1(3)
6079       common /sccalc/ time11,time12,time112,theti,it,nlobit
6080       delta=0.02d0*pi
6081       escloc=0.0D0
6082       do i=loc_start,loc_end
6083         if (itype(i).eq.ntyp1) cycle
6084         costtab(i+1) =dcos(theta(i+1))
6085         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6086         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6087         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6088         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6089         cosfac=dsqrt(cosfac2)
6090         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6091         sinfac=dsqrt(sinfac2)
6092         it=iabs(itype(i))
6093         if (it.eq.10) goto 1
6094 c
6095 C  Compute the axes of tghe local cartesian coordinates system; store in
6096 c   x_prime, y_prime and z_prime
6097 c
6098         do j=1,3
6099           x_prime(j) = 0.00
6100           y_prime(j) = 0.00
6101           z_prime(j) = 0.00
6102         enddo
6103 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6104 C     &   dc_norm(3,i+nres)
6105         do j = 1,3
6106           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6107           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6108         enddo
6109         do j = 1,3
6110           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6111         enddo
6112 c       write (2,*) "i",i
6113 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6114 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6115 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6116 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6117 c      & " xy",scalar(x_prime(1),y_prime(1)),
6118 c      & " xz",scalar(x_prime(1),z_prime(1)),
6119 c      & " yy",scalar(y_prime(1),y_prime(1)),
6120 c      & " yz",scalar(y_prime(1),z_prime(1)),
6121 c      & " zz",scalar(z_prime(1),z_prime(1))
6122 c
6123 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6124 C to local coordinate system. Store in xx, yy, zz.
6125 c
6126         xx=0.0d0
6127         yy=0.0d0
6128         zz=0.0d0
6129         do j = 1,3
6130           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6131           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6132           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6133         enddo
6134
6135         xxtab(i)=xx
6136         yytab(i)=yy
6137         zztab(i)=zz
6138 C
6139 C Compute the energy of the ith side cbain
6140 C
6141 c        write (2,*) "xx",xx," yy",yy," zz",zz
6142         it=iabs(itype(i))
6143         do j = 1,65
6144           x(j) = sc_parmin(j,it)
6145         enddo
6146 #ifdef CHECK_COORD
6147 Cc diagnostics - remove later
6148         xx1 = dcos(alph(2))
6149         yy1 = dsin(alph(2))*dcos(omeg(2))
6150         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6151         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6152      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6153      &    xx1,yy1,zz1
6154 C,"  --- ", xx_w,yy_w,zz_w
6155 c end diagnostics
6156 #endif
6157         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6158      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6159      &   + x(10)*yy*zz
6160         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6161      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6162      & + x(20)*yy*zz
6163         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6164      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6165      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6166      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6167      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6168      &  +x(40)*xx*yy*zz
6169         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6170      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6171      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6172      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6173      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6174      &  +x(60)*xx*yy*zz
6175         dsc_i   = 0.743d0+x(61)
6176         dp2_i   = 1.9d0+x(62)
6177         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6178      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6179         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6180      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6181         s1=(1+x(63))/(0.1d0 + dscp1)
6182         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6183         s2=(1+x(65))/(0.1d0 + dscp2)
6184         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6185         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6186      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6187 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6188 c     &   sumene4,
6189 c     &   dscp1,dscp2,sumene
6190 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6191         escloc = escloc + sumene
6192 c        write (2,*) "escloc",escloc
6193 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6194 c     &  zz,xx,yy
6195         if (.not. calc_grad) goto 1
6196 #ifdef DEBUG
6197 C
6198 C This section to check the numerical derivatives of the energy of ith side
6199 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6200 C #define DEBUG in the code to turn it on.
6201 C
6202         write (2,*) "sumene               =",sumene
6203         aincr=1.0d-7
6204         xxsave=xx
6205         xx=xx+aincr
6206         write (2,*) xx,yy,zz
6207         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6208         de_dxx_num=(sumenep-sumene)/aincr
6209         xx=xxsave
6210         write (2,*) "xx+ sumene from enesc=",sumenep
6211         yysave=yy
6212         yy=yy+aincr
6213         write (2,*) xx,yy,zz
6214         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6215         de_dyy_num=(sumenep-sumene)/aincr
6216         yy=yysave
6217         write (2,*) "yy+ sumene from enesc=",sumenep
6218         zzsave=zz
6219         zz=zz+aincr
6220         write (2,*) xx,yy,zz
6221         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6222         de_dzz_num=(sumenep-sumene)/aincr
6223         zz=zzsave
6224         write (2,*) "zz+ sumene from enesc=",sumenep
6225         costsave=cost2tab(i+1)
6226         sintsave=sint2tab(i+1)
6227         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6228         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6229         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6230         de_dt_num=(sumenep-sumene)/aincr
6231         write (2,*) " t+ sumene from enesc=",sumenep
6232         cost2tab(i+1)=costsave
6233         sint2tab(i+1)=sintsave
6234 C End of diagnostics section.
6235 #endif
6236 C
6237 C Compute the gradient of esc
6238 C
6239         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6240         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6241         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6242         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6243         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6244         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6245         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6246         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6247         pom1=(sumene3*sint2tab(i+1)+sumene1)
6248      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6249         pom2=(sumene4*cost2tab(i+1)+sumene2)
6250      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6251         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6252         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6253      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6254      &  +x(40)*yy*zz
6255         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6256         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6257      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6258      &  +x(60)*yy*zz
6259         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6260      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6261      &        +(pom1+pom2)*pom_dx
6262 #ifdef DEBUG
6263         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6264 #endif
6265 C
6266         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6267         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6268      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6269      &  +x(40)*xx*zz
6270         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6271         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6272      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6273      &  +x(59)*zz**2 +x(60)*xx*zz
6274         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6275      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6276      &        +(pom1-pom2)*pom_dy
6277 #ifdef DEBUG
6278         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6279 #endif
6280 C
6281         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6282      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6283      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6284      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6285      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6286      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6287      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6288      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6289 #ifdef DEBUG
6290         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6291 #endif
6292 C
6293         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6294      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6295      &  +pom1*pom_dt1+pom2*pom_dt2
6296 #ifdef DEBUG
6297         write(2,*), "de_dt = ", de_dt,de_dt_num
6298 #endif
6299 c
6300 C
6301        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6302        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6303        cosfac2xx=cosfac2*xx
6304        sinfac2yy=sinfac2*yy
6305        do k = 1,3
6306          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6307      &      vbld_inv(i+1)
6308          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6309      &      vbld_inv(i)
6310          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6311          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6312 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6313 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6314 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6315 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6316          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6317          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6318          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6319          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6320          dZZ_Ci1(k)=0.0d0
6321          dZZ_Ci(k)=0.0d0
6322          do j=1,3
6323            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6324      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6325            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6326      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6327          enddo
6328
6329          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6330          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6331          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6332 c
6333          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6334          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6335        enddo
6336
6337        do k=1,3
6338          dXX_Ctab(k,i)=dXX_Ci(k)
6339          dXX_C1tab(k,i)=dXX_Ci1(k)
6340          dYY_Ctab(k,i)=dYY_Ci(k)
6341          dYY_C1tab(k,i)=dYY_Ci1(k)
6342          dZZ_Ctab(k,i)=dZZ_Ci(k)
6343          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6344          dXX_XYZtab(k,i)=dXX_XYZ(k)
6345          dYY_XYZtab(k,i)=dYY_XYZ(k)
6346          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6347        enddo
6348
6349        do k = 1,3
6350 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6351 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6352 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6353 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6354 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6355 c     &    dt_dci(k)
6356 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6357 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6358          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6359      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6360          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6361      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6362          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6363      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6364        enddo
6365 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6366 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6367
6368 C to check gradient call subroutine check_grad
6369
6370     1 continue
6371       enddo
6372       return
6373       end
6374 #endif
6375 c------------------------------------------------------------------------------
6376       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6377 C
6378 C This procedure calculates two-body contact function g(rij) and its derivative:
6379 C
6380 C           eps0ij                                     !       x < -1
6381 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6382 C            0                                         !       x > 1
6383 C
6384 C where x=(rij-r0ij)/delta
6385 C
6386 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6387 C
6388       implicit none
6389       double precision rij,r0ij,eps0ij,fcont,fprimcont
6390       double precision x,x2,x4,delta
6391 c     delta=0.02D0*r0ij
6392 c      delta=0.2D0*r0ij
6393       x=(rij-r0ij)/delta
6394       if (x.lt.-1.0D0) then
6395         fcont=eps0ij
6396         fprimcont=0.0D0
6397       else if (x.le.1.0D0) then
6398         x2=x*x
6399         x4=x2*x2
6400         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6401         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6402       else
6403         fcont=0.0D0
6404         fprimcont=0.0D0
6405       endif
6406       return
6407       end
6408 c------------------------------------------------------------------------------
6409       subroutine splinthet(theti,delta,ss,ssder)
6410       implicit real*8 (a-h,o-z)
6411       include 'DIMENSIONS'
6412       include 'DIMENSIONS.ZSCOPT'
6413       include 'COMMON.VAR'
6414       include 'COMMON.GEO'
6415       thetup=pi-delta
6416       thetlow=delta
6417       if (theti.gt.pipol) then
6418         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6419       else
6420         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6421         ssder=-ssder
6422       endif
6423       return
6424       end
6425 c------------------------------------------------------------------------------
6426       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6427       implicit none
6428       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6429       double precision ksi,ksi2,ksi3,a1,a2,a3
6430       a1=fprim0*delta/(f1-f0)
6431       a2=3.0d0-2.0d0*a1
6432       a3=a1-2.0d0
6433       ksi=(x-x0)/delta
6434       ksi2=ksi*ksi
6435       ksi3=ksi2*ksi
6436       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6437       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6438       return
6439       end
6440 c------------------------------------------------------------------------------
6441       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6442       implicit none
6443       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6444       double precision ksi,ksi2,ksi3,a1,a2,a3
6445       ksi=(x-x0)/delta
6446       ksi2=ksi*ksi
6447       ksi3=ksi2*ksi
6448       a1=fprim0x*delta
6449       a2=3*(f1x-f0x)-2*fprim0x*delta
6450       a3=fprim0x*delta-2*(f1x-f0x)
6451       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6452       return
6453       end
6454 C-----------------------------------------------------------------------------
6455 #ifdef CRYST_TOR
6456 C-----------------------------------------------------------------------------
6457       subroutine etor(etors,fact)
6458       implicit real*8 (a-h,o-z)
6459       include 'DIMENSIONS'
6460       include 'DIMENSIONS.ZSCOPT'
6461       include 'COMMON.VAR'
6462       include 'COMMON.GEO'
6463       include 'COMMON.LOCAL'
6464       include 'COMMON.TORSION'
6465       include 'COMMON.INTERACT'
6466       include 'COMMON.DERIV'
6467       include 'COMMON.CHAIN'
6468       include 'COMMON.NAMES'
6469       include 'COMMON.IOUNITS'
6470       include 'COMMON.FFIELD'
6471       include 'COMMON.TORCNSTR'
6472       logical lprn
6473 C Set lprn=.true. for debugging
6474       lprn=.false.
6475 c      lprn=.true.
6476       etors=0.0D0
6477       do i=iphi_start,iphi_end
6478         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6479      &      .or. itype(i).eq.ntyp1) cycle
6480         itori=itortyp(itype(i-2))
6481         itori1=itortyp(itype(i-1))
6482         phii=phi(i)
6483         gloci=0.0D0
6484 C Proline-Proline pair is a special case...
6485         if (itori.eq.3 .and. itori1.eq.3) then
6486           if (phii.gt.-dwapi3) then
6487             cosphi=dcos(3*phii)
6488             fac=1.0D0/(1.0D0-cosphi)
6489             etorsi=v1(1,3,3)*fac
6490             etorsi=etorsi+etorsi
6491             etors=etors+etorsi-v1(1,3,3)
6492             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6493           endif
6494           do j=1,3
6495             v1ij=v1(j+1,itori,itori1)
6496             v2ij=v2(j+1,itori,itori1)
6497             cosphi=dcos(j*phii)
6498             sinphi=dsin(j*phii)
6499             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6500             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6501           enddo
6502         else
6503           do j=1,nterm_old
6504             v1ij=v1(j,itori,itori1)
6505             v2ij=v2(j,itori,itori1)
6506             cosphi=dcos(j*phii)
6507             sinphi=dsin(j*phii)
6508             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6509             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6510           enddo
6511         endif
6512         if (lprn)
6513      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6514      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6515      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6516         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6517 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6518       enddo
6519       return
6520       end
6521 c------------------------------------------------------------------------------
6522 #else
6523       subroutine etor(etors,fact)
6524       implicit real*8 (a-h,o-z)
6525       include 'DIMENSIONS'
6526       include 'DIMENSIONS.ZSCOPT'
6527       include 'COMMON.VAR'
6528       include 'COMMON.GEO'
6529       include 'COMMON.LOCAL'
6530       include 'COMMON.TORSION'
6531       include 'COMMON.INTERACT'
6532       include 'COMMON.DERIV'
6533       include 'COMMON.CHAIN'
6534       include 'COMMON.NAMES'
6535       include 'COMMON.IOUNITS'
6536       include 'COMMON.FFIELD'
6537       include 'COMMON.TORCNSTR'
6538       logical lprn
6539 C Set lprn=.true. for debugging
6540       lprn=.false.
6541 c      lprn=.true.
6542       etors=0.0D0
6543       do i=iphi_start,iphi_end
6544         if (i.le.2) cycle
6545         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6546      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6547 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6548 C     &       .or. itype(i).eq.ntyp1) cycle
6549         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6550          if (iabs(itype(i)).eq.20) then
6551          iblock=2
6552          else
6553          iblock=1
6554          endif
6555         itori=itortyp(itype(i-2))
6556         itori1=itortyp(itype(i-1))
6557         phii=phi(i)
6558         gloci=0.0D0
6559 C Regular cosine and sine terms
6560         do j=1,nterm(itori,itori1,iblock)
6561           v1ij=v1(j,itori,itori1,iblock)
6562           v2ij=v2(j,itori,itori1,iblock)
6563           cosphi=dcos(j*phii)
6564           sinphi=dsin(j*phii)
6565           etors=etors+v1ij*cosphi+v2ij*sinphi
6566           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6567         enddo
6568 C Lorentz terms
6569 C                         v1
6570 C  E = SUM ----------------------------------- - v1
6571 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6572 C
6573         cosphi=dcos(0.5d0*phii)
6574         sinphi=dsin(0.5d0*phii)
6575         do j=1,nlor(itori,itori1,iblock)
6576           vl1ij=vlor1(j,itori,itori1)
6577           vl2ij=vlor2(j,itori,itori1)
6578           vl3ij=vlor3(j,itori,itori1)
6579           pom=vl2ij*cosphi+vl3ij*sinphi
6580           pom1=1.0d0/(pom*pom+1.0d0)
6581           etors=etors+vl1ij*pom1
6582 c          if (energy_dec) etors_ii=etors_ii+
6583 c     &                vl1ij*pom1
6584           pom=-pom*pom1*pom1
6585           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6586         enddo
6587 C Subtract the constant term
6588         etors=etors-v0(itori,itori1,iblock)
6589         if (lprn)
6590      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6591      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6592      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6593         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6594 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6595  1215   continue
6596       enddo
6597       return
6598       end
6599 c----------------------------------------------------------------------------
6600       subroutine etor_d(etors_d,fact2)
6601 C 6/23/01 Compute double torsional energy
6602       implicit real*8 (a-h,o-z)
6603       include 'DIMENSIONS'
6604       include 'DIMENSIONS.ZSCOPT'
6605       include 'COMMON.VAR'
6606       include 'COMMON.GEO'
6607       include 'COMMON.LOCAL'
6608       include 'COMMON.TORSION'
6609       include 'COMMON.INTERACT'
6610       include 'COMMON.DERIV'
6611       include 'COMMON.CHAIN'
6612       include 'COMMON.NAMES'
6613       include 'COMMON.IOUNITS'
6614       include 'COMMON.FFIELD'
6615       include 'COMMON.TORCNSTR'
6616       logical lprn
6617 C Set lprn=.true. for debugging
6618       lprn=.false.
6619 c     lprn=.true.
6620       etors_d=0.0D0
6621       do i=iphi_start,iphi_end-1
6622         if (i.le.3) cycle
6623 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6624 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6625          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6626      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6627      &  (itype(i+1).eq.ntyp1)) cycle
6628         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6629      &     goto 1215
6630         itori=itortyp(itype(i-2))
6631         itori1=itortyp(itype(i-1))
6632         itori2=itortyp(itype(i))
6633         phii=phi(i)
6634         phii1=phi(i+1)
6635         gloci1=0.0D0
6636         gloci2=0.0D0
6637         iblock=1
6638         if (iabs(itype(i+1)).eq.20) iblock=2
6639 C Regular cosine and sine terms
6640         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6641           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6642           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6643           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6644           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6645           cosphi1=dcos(j*phii)
6646           sinphi1=dsin(j*phii)
6647           cosphi2=dcos(j*phii1)
6648           sinphi2=dsin(j*phii1)
6649           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6650      &     v2cij*cosphi2+v2sij*sinphi2
6651           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6652           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6653         enddo
6654         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6655           do l=1,k-1
6656             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6657             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6658             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6659             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6660             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6661             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6662             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6663             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6664             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6665      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6666             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6667      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6668             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6669      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6670           enddo
6671         enddo
6672         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6673         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6674  1215   continue
6675       enddo
6676       return
6677       end
6678 #endif
6679 c---------------------------------------------------------------------------
6680 C The rigorous attempt to derive energy function
6681       subroutine etor_kcc(etors,fact)
6682       implicit real*8 (a-h,o-z)
6683       include 'DIMENSIONS'
6684       include 'DIMENSIONS.ZSCOPT'
6685       include 'COMMON.VAR'
6686       include 'COMMON.GEO'
6687       include 'COMMON.LOCAL'
6688       include 'COMMON.TORSION'
6689       include 'COMMON.INTERACT'
6690       include 'COMMON.DERIV'
6691       include 'COMMON.CHAIN'
6692       include 'COMMON.NAMES'
6693       include 'COMMON.IOUNITS'
6694       include 'COMMON.FFIELD'
6695       include 'COMMON.TORCNSTR'
6696       include 'COMMON.CONTROL'
6697       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6698       logical lprn
6699 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6700 C Set lprn=.true. for debugging
6701       lprn=energy_dec
6702 c     lprn=.true.
6703 C      print *,"wchodze kcc"
6704       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6705       etors=0.0D0
6706       do i=iphi_start,iphi_end
6707 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6708 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6709 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6710 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6711         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6712      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6713         itori=itortyp(itype(i-2))
6714         itori1=itortyp(itype(i-1))
6715         phii=phi(i)
6716         glocig=0.0D0
6717         glocit1=0.0d0
6718         glocit2=0.0d0
6719 C to avoid multiple devision by 2
6720 c        theti22=0.5d0*theta(i)
6721 C theta 12 is the theta_1 /2
6722 C theta 22 is theta_2 /2
6723 c        theti12=0.5d0*theta(i-1)
6724 C and appropriate sinus function
6725         sinthet1=dsin(theta(i-1))
6726         sinthet2=dsin(theta(i))
6727         costhet1=dcos(theta(i-1))
6728         costhet2=dcos(theta(i))
6729 C to speed up lets store its mutliplication
6730         sint1t2=sinthet2*sinthet1
6731         sint1t2n=1.0d0
6732 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6733 C +d_n*sin(n*gamma)) *
6734 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6735 C we have two sum 1) Non-Chebyshev which is with n and gamma
6736         nval=nterm_kcc_Tb(itori,itori1)
6737         c1(0)=0.0d0
6738         c2(0)=0.0d0
6739         c1(1)=1.0d0
6740         c2(1)=1.0d0
6741         do j=2,nval
6742           c1(j)=c1(j-1)*costhet1
6743           c2(j)=c2(j-1)*costhet2
6744         enddo
6745         etori=0.0d0
6746         do j=1,nterm_kcc(itori,itori1)
6747           cosphi=dcos(j*phii)
6748           sinphi=dsin(j*phii)
6749           sint1t2n1=sint1t2n
6750           sint1t2n=sint1t2n*sint1t2
6751           sumvalc=0.0d0
6752           gradvalct1=0.0d0
6753           gradvalct2=0.0d0
6754           do k=1,nval
6755             do l=1,nval
6756               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6757               gradvalct1=gradvalct1+
6758      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6759               gradvalct2=gradvalct2+
6760      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6761             enddo
6762           enddo
6763           gradvalct1=-gradvalct1*sinthet1
6764           gradvalct2=-gradvalct2*sinthet2
6765           sumvals=0.0d0
6766           gradvalst1=0.0d0
6767           gradvalst2=0.0d0
6768           do k=1,nval
6769             do l=1,nval
6770               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6771               gradvalst1=gradvalst1+
6772      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6773               gradvalst2=gradvalst2+
6774      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6775             enddo
6776           enddo
6777           gradvalst1=-gradvalst1*sinthet1
6778           gradvalst2=-gradvalst2*sinthet2
6779           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6780 C glocig is the gradient local i site in gamma
6781           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6782 C now gradient over theta_1
6783           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6784      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6785           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6786      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6787         enddo ! j
6788         etors=etors+etori
6789 C derivative over gamma
6790         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6791 C derivative over theta1
6792         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6793 C now derivative over theta2
6794         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6795         if (lprn) then
6796           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6797      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6798           write (iout,*) "c1",(c1(k),k=0,nval),
6799      &    " c2",(c2(k),k=0,nval)
6800           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6801         endif
6802       enddo
6803       return
6804       end
6805 c---------------------------------------------------------------------------------------------
6806       subroutine etor_constr(edihcnstr)
6807       implicit real*8 (a-h,o-z)
6808       include 'DIMENSIONS'
6809       include 'DIMENSIONS.ZSCOPT'
6810       include 'COMMON.VAR'
6811       include 'COMMON.GEO'
6812       include 'COMMON.LOCAL'
6813       include 'COMMON.TORSION'
6814       include 'COMMON.INTERACT'
6815       include 'COMMON.DERIV'
6816       include 'COMMON.CHAIN'
6817       include 'COMMON.NAMES'
6818       include 'COMMON.IOUNITS'
6819       include 'COMMON.FFIELD'
6820       include 'COMMON.TORCNSTR'
6821       include 'COMMON.CONTROL'
6822 ! 6/20/98 - dihedral angle constraints
6823       edihcnstr=0.0d0
6824 c      do i=1,ndih_constr
6825 c      write (iout,*) "idihconstr_start",idihconstr_start,
6826 c     &  " idihconstr_end",idihconstr_end
6827
6828       if (raw_psipred) then
6829         do i=idihconstr_start,idihconstr_end
6830           itori=idih_constr(i)
6831           phii=phi(itori)
6832           gaudih_i=vpsipred(1,i)
6833           gauder_i=0.0d0
6834           do j=1,2
6835             s = sdihed(j,i)
6836             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6837             dexpcos_i=dexp(-cos_i*cos_i)
6838             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6839             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6840      &            *cos_i*dexpcos_i/s**2
6841           enddo
6842           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6843           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6844           if (energy_dec)
6845      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6846      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6847      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6848      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6849      &     -wdihc*dlog(gaudih_i)
6850         enddo
6851       else
6852
6853       do i=idihconstr_start,idihconstr_end
6854         itori=idih_constr(i)
6855         phii=phi(itori)
6856         difi=pinorm(phii-phi0(i))
6857         if (difi.gt.drange(i)) then
6858           difi=difi-drange(i)
6859           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6860           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6861         else if (difi.lt.-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
6866           difi=0.0
6867         endif
6868       enddo
6869
6870       endif
6871
6872 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6873       return
6874       end
6875 c----------------------------------------------------------------------------
6876 C The rigorous attempt to derive energy function
6877       subroutine ebend_kcc(etheta)
6878
6879       implicit real*8 (a-h,o-z)
6880       include 'DIMENSIONS'
6881       include 'DIMENSIONS.ZSCOPT'
6882       include 'COMMON.VAR'
6883       include 'COMMON.GEO'
6884       include 'COMMON.LOCAL'
6885       include 'COMMON.TORSION'
6886       include 'COMMON.INTERACT'
6887       include 'COMMON.DERIV'
6888       include 'COMMON.CHAIN'
6889       include 'COMMON.NAMES'
6890       include 'COMMON.IOUNITS'
6891       include 'COMMON.FFIELD'
6892       include 'COMMON.TORCNSTR'
6893       include 'COMMON.CONTROL'
6894       logical lprn
6895       double precision thybt1(maxang_kcc)
6896 C Set lprn=.true. for debugging
6897       lprn=energy_dec
6898 c     lprn=.true.
6899 C      print *,"wchodze kcc"
6900       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6901       etheta=0.0D0
6902       do i=ithet_start,ithet_end
6903 c        print *,i,itype(i-1),itype(i),itype(i-2)
6904         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6905      &  .or.itype(i).eq.ntyp1) cycle
6906         iti=iabs(itortyp(itype(i-1)))
6907         sinthet=dsin(theta(i))
6908         costhet=dcos(theta(i))
6909         do j=1,nbend_kcc_Tb(iti)
6910           thybt1(j)=v1bend_chyb(j,iti)
6911         enddo
6912         sumth1thyb=v1bend_chyb(0,iti)+
6913      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6914         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6915      &    sumth1thyb
6916         ihelp=nbend_kcc_Tb(iti)-1
6917         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6918         etheta=etheta+sumth1thyb
6919 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6920         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6921       enddo
6922       return
6923       end
6924 c-------------------------------------------------------------------------------------
6925       subroutine etheta_constr(ethetacnstr)
6926
6927       implicit real*8 (a-h,o-z)
6928       include 'DIMENSIONS'
6929       include 'DIMENSIONS.ZSCOPT'
6930       include 'COMMON.VAR'
6931       include 'COMMON.GEO'
6932       include 'COMMON.LOCAL'
6933       include 'COMMON.TORSION'
6934       include 'COMMON.INTERACT'
6935       include 'COMMON.DERIV'
6936       include 'COMMON.CHAIN'
6937       include 'COMMON.NAMES'
6938       include 'COMMON.IOUNITS'
6939       include 'COMMON.FFIELD'
6940       include 'COMMON.TORCNSTR'
6941       include 'COMMON.CONTROL'
6942       ethetacnstr=0.0d0
6943 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6944       do i=ithetaconstr_start,ithetaconstr_end
6945         itheta=itheta_constr(i)
6946         thetiii=theta(itheta)
6947         difi=pinorm(thetiii-theta_constr0(i))
6948         if (difi.gt.theta_drange(i)) then
6949           difi=difi-theta_drange(i)
6950           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6951           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6952      &    +for_thet_constr(i)*difi**3
6953         else if (difi.lt.-drange(i)) then
6954           difi=difi+drange(i)
6955           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6956           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6957      &    +for_thet_constr(i)*difi**3
6958         else
6959           difi=0.0
6960         endif
6961        if (energy_dec) then
6962         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6963      &    i,itheta,rad2deg*thetiii,
6964      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6965      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6966      &    gloc(itheta+nphi-2,icg)
6967         endif
6968       enddo
6969       return
6970       end
6971 c------------------------------------------------------------------------------
6972 c------------------------------------------------------------------------------
6973       subroutine eback_sc_corr(esccor)
6974 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6975 c        conformational states; temporarily implemented as differences
6976 c        between UNRES torsional potentials (dependent on three types of
6977 c        residues) and the torsional potentials dependent on all 20 types
6978 c        of residues computed from AM1 energy surfaces of terminally-blocked
6979 c        amino-acid residues.
6980       implicit real*8 (a-h,o-z)
6981       include 'DIMENSIONS'
6982       include 'DIMENSIONS.ZSCOPT'
6983       include 'COMMON.VAR'
6984       include 'COMMON.GEO'
6985       include 'COMMON.LOCAL'
6986       include 'COMMON.TORSION'
6987       include 'COMMON.SCCOR'
6988       include 'COMMON.INTERACT'
6989       include 'COMMON.DERIV'
6990       include 'COMMON.CHAIN'
6991       include 'COMMON.NAMES'
6992       include 'COMMON.IOUNITS'
6993       include 'COMMON.FFIELD'
6994       include 'COMMON.CONTROL'
6995       logical lprn
6996 C Set lprn=.true. for debugging
6997       lprn=.false.
6998 c      lprn=.true.
6999 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7000       esccor=0.0D0
7001       do i=itau_start,itau_end
7002         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7003         esccor_ii=0.0D0
7004         isccori=isccortyp(itype(i-2))
7005         isccori1=isccortyp(itype(i-1))
7006         phii=phi(i)
7007         do intertyp=1,3 !intertyp
7008 cc Added 09 May 2012 (Adasko)
7009 cc  Intertyp means interaction type of backbone mainchain correlation:
7010 c   1 = SC...Ca...Ca...Ca
7011 c   2 = Ca...Ca...Ca...SC
7012 c   3 = SC...Ca...Ca...SCi
7013         gloci=0.0D0
7014         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7015      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7016      &      (itype(i-1).eq.ntyp1)))
7017      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7018      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7019      &     .or.(itype(i).eq.ntyp1)))
7020      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7021      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7022      &      (itype(i-3).eq.ntyp1)))) cycle
7023         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7024         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7025      & cycle
7026        do j=1,nterm_sccor(isccori,isccori1)
7027           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7028           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7029           cosphi=dcos(j*tauangle(intertyp,i))
7030           sinphi=dsin(j*tauangle(intertyp,i))
7031            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7032            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7033          enddo
7034 C      write (iout,*)"EBACK_SC_COR",esccor,i
7035 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7036 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7037 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7038         if (lprn)
7039      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7040      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7041      &  (v1sccor(j,1,itori,itori1),j=1,6)
7042      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7043 c        gsccor_loc(i-3)=gloci
7044        enddo !intertyp
7045       enddo
7046       return
7047       end
7048 #ifdef FOURBODY
7049 c------------------------------------------------------------------------------
7050       subroutine multibody(ecorr)
7051 C This subroutine calculates multi-body contributions to energy following
7052 C the idea of Skolnick et al. If side chains I and J make a contact and
7053 C at the same time side chains I+1 and J+1 make a contact, an extra
7054 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7055       implicit real*8 (a-h,o-z)
7056       include 'DIMENSIONS'
7057       include 'COMMON.IOUNITS'
7058       include 'COMMON.DERIV'
7059       include 'COMMON.INTERACT'
7060       include 'COMMON.CONTACTS'
7061       include 'COMMON.CONTMAT'
7062       include 'COMMON.CORRMAT'
7063       double precision gx(3),gx1(3)
7064       logical lprn
7065
7066 C Set lprn=.true. for debugging
7067       lprn=.false.
7068
7069       if (lprn) then
7070         write (iout,'(a)') 'Contact function values:'
7071         do i=nnt,nct-2
7072           write (iout,'(i2,20(1x,i2,f10.5))')
7073      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7074         enddo
7075       endif
7076       ecorr=0.0D0
7077       do i=nnt,nct
7078         do j=1,3
7079           gradcorr(j,i)=0.0D0
7080           gradxorr(j,i)=0.0D0
7081         enddo
7082       enddo
7083       do i=nnt,nct-2
7084
7085         DO ISHIFT = 3,4
7086
7087         i1=i+ishift
7088         num_conti=num_cont(i)
7089         num_conti1=num_cont(i1)
7090         do jj=1,num_conti
7091           j=jcont(jj,i)
7092           do kk=1,num_conti1
7093             j1=jcont(kk,i1)
7094             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7095 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7096 cd   &                   ' ishift=',ishift
7097 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7098 C The system gains extra energy.
7099               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7100             endif   ! j1==j+-ishift
7101           enddo     ! kk
7102         enddo       ! jj
7103
7104         ENDDO ! ISHIFT
7105
7106       enddo         ! i
7107       return
7108       end
7109 c------------------------------------------------------------------------------
7110       double precision function esccorr(i,j,k,l,jj,kk)
7111       implicit real*8 (a-h,o-z)
7112       include 'DIMENSIONS'
7113       include 'COMMON.IOUNITS'
7114       include 'COMMON.DERIV'
7115       include 'COMMON.INTERACT'
7116       include 'COMMON.CONTACTS'
7117       include 'COMMON.CONTMAT'
7118       include 'COMMON.CORRMAT'
7119       double precision gx(3),gx1(3)
7120       logical lprn
7121       lprn=.false.
7122       eij=facont(jj,i)
7123       ekl=facont(kk,k)
7124 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7125 C Calculate the multi-body contribution to energy.
7126 C Calculate multi-body contributions to the gradient.
7127 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7128 cd   & k,l,(gacont(m,kk,k),m=1,3)
7129       do m=1,3
7130         gx(m) =ekl*gacont(m,jj,i)
7131         gx1(m)=eij*gacont(m,kk,k)
7132         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7133         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7134         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7135         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7136       enddo
7137       do m=i,j-1
7138         do ll=1,3
7139           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7140         enddo
7141       enddo
7142       do m=k,l-1
7143         do ll=1,3
7144           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7145         enddo
7146       enddo
7147       esccorr=-eij*ekl
7148       return
7149       end
7150 c------------------------------------------------------------------------------
7151       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7152 C This subroutine calculates multi-body contributions to hydrogen-bonding
7153       implicit real*8 (a-h,o-z)
7154       include 'DIMENSIONS'
7155       include 'DIMENSIONS.ZSCOPT'
7156       include 'COMMON.IOUNITS'
7157       include 'COMMON.FFIELD'
7158       include 'COMMON.DERIV'
7159       include 'COMMON.INTERACT'
7160       include 'COMMON.CONTACTS'
7161       include 'COMMON.CONTMAT'
7162       include 'COMMON.CORRMAT'
7163       double precision gx(3),gx1(3)
7164       logical lprn,ldone
7165
7166 C Set lprn=.true. for debugging
7167       lprn=.false.
7168       if (lprn) then
7169         write (iout,'(a)') 'Contact function values:'
7170         do i=nnt,nct-2
7171           write (iout,'(2i3,50(1x,i2,f5.2))')
7172      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7173      &    j=1,num_cont_hb(i))
7174         enddo
7175       endif
7176       ecorr=0.0D0
7177 C Remove the loop below after debugging !!!
7178       do i=nnt,nct
7179         do j=1,3
7180           gradcorr(j,i)=0.0D0
7181           gradxorr(j,i)=0.0D0
7182         enddo
7183       enddo
7184 C Calculate the local-electrostatic correlation terms
7185       do i=iatel_s,iatel_e+1
7186         i1=i+1
7187         num_conti=num_cont_hb(i)
7188         num_conti1=num_cont_hb(i+1)
7189         do jj=1,num_conti
7190           j=jcont_hb(jj,i)
7191           do kk=1,num_conti1
7192             j1=jcont_hb(kk,i1)
7193 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7194 c     &         ' jj=',jj,' kk=',kk
7195             if (j1.eq.j+1 .or. j1.eq.j-1) then
7196 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7197 C The system gains extra energy.
7198               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7199               n_corr=n_corr+1
7200             else if (j1.eq.j) then
7201 C Contacts I-J and I-(J+1) occur simultaneously.
7202 C The system loses extra energy.
7203 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7204             endif
7205           enddo ! kk
7206           do kk=1,num_conti
7207             j1=jcont_hb(kk,i)
7208 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7209 c    &         ' jj=',jj,' kk=',kk
7210             if (j1.eq.j+1) then
7211 C Contacts I-J and (I+1)-J occur simultaneously.
7212 C The system loses extra energy.
7213 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7214             endif ! j1==j+1
7215           enddo ! kk
7216         enddo ! jj
7217       enddo ! i
7218       return
7219       end
7220 c------------------------------------------------------------------------------
7221       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7222      &  n_corr1)
7223 C This subroutine calculates multi-body contributions to hydrogen-bonding
7224       implicit real*8 (a-h,o-z)
7225       include 'DIMENSIONS'
7226       include 'DIMENSIONS.ZSCOPT'
7227       include 'COMMON.IOUNITS'
7228 #ifdef MPI
7229       include "mpif.h"
7230 #endif
7231       include 'COMMON.FFIELD'
7232       include 'COMMON.DERIV'
7233       include 'COMMON.LOCAL'
7234       include 'COMMON.INTERACT'
7235       include 'COMMON.CONTACTS'
7236       include 'COMMON.CONTMAT'
7237       include 'COMMON.CORRMAT'
7238       include 'COMMON.CHAIN'
7239       include 'COMMON.CONTROL'
7240       include 'COMMON.SHIELD'
7241       double precision gx(3),gx1(3)
7242       integer num_cont_hb_old(maxres)
7243       logical lprn,ldone
7244       double precision eello4,eello5,eelo6,eello_turn6
7245       external eello4,eello5,eello6,eello_turn6
7246 C Set lprn=.true. for debugging
7247       lprn=.false.
7248       eturn6=0.0d0
7249       if (lprn) then
7250         write (iout,'(a)') 'Contact function values:'
7251         do i=nnt,nct-2
7252           write (iout,'(2i3,50(1x,i2,5f6.3))')
7253      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7254      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7255         enddo
7256       endif
7257       ecorr=0.0D0
7258       ecorr5=0.0d0
7259       ecorr6=0.0d0
7260 C Remove the loop below after debugging !!!
7261       do i=nnt,nct
7262         do j=1,3
7263           gradcorr(j,i)=0.0D0
7264           gradxorr(j,i)=0.0D0
7265         enddo
7266       enddo
7267 C Calculate the dipole-dipole interaction energies
7268       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7269       do i=iatel_s,iatel_e+1
7270         num_conti=num_cont_hb(i)
7271         do jj=1,num_conti
7272           j=jcont_hb(jj,i)
7273 #ifdef MOMENT
7274           call dipole(i,j,jj)
7275 #endif
7276         enddo
7277       enddo
7278       endif
7279 C Calculate the local-electrostatic correlation terms
7280 c                write (iout,*) "gradcorr5 in eello5 before loop"
7281 c                do iii=1,nres
7282 c                  write (iout,'(i5,3f10.5)')
7283 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7284 c                enddo
7285       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7286 c        write (iout,*) "corr loop i",i
7287         i1=i+1
7288         num_conti=num_cont_hb(i)
7289         num_conti1=num_cont_hb(i+1)
7290         do jj=1,num_conti
7291           j=jcont_hb(jj,i)
7292           jp=iabs(j)
7293           do kk=1,num_conti1
7294             j1=jcont_hb(kk,i1)
7295             jp1=iabs(j1)
7296 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7297 c     &         ' jj=',jj,' kk=',kk
7298 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7299             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7300      &          .or. j.lt.0 .and. j1.gt.0) .and.
7301      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7302 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7303 C The system gains extra energy.
7304               n_corr=n_corr+1
7305               sqd1=dsqrt(d_cont(jj,i))
7306               sqd2=dsqrt(d_cont(kk,i1))
7307               sred_geom = sqd1*sqd2
7308               IF (sred_geom.lt.cutoff_corr) THEN
7309                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7310      &            ekont,fprimcont)
7311 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7312 cd     &         ' jj=',jj,' kk=',kk
7313                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7314                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7315                 do l=1,3
7316                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7317                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7318                 enddo
7319                 n_corr1=n_corr1+1
7320 cd               write (iout,*) 'sred_geom=',sred_geom,
7321 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7322 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7323 cd               write (iout,*) "g_contij",g_contij
7324 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7325 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7326                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7327                 if (wcorr4.gt.0.0d0)
7328      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7329 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7330                   if (energy_dec.and.wcorr4.gt.0.0d0)
7331      1                 write (iout,'(a6,4i5,0pf7.3)')
7332      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7333 c                write (iout,*) "gradcorr5 before eello5"
7334 c                do iii=1,nres
7335 c                  write (iout,'(i5,3f10.5)')
7336 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7337 c                enddo
7338                 if (wcorr5.gt.0.0d0)
7339      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7340 c                write (iout,*) "gradcorr5 after eello5"
7341 c                do iii=1,nres
7342 c                  write (iout,'(i5,3f10.5)')
7343 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7344 c                enddo
7345                   if (energy_dec.and.wcorr5.gt.0.0d0)
7346      1                 write (iout,'(a6,4i5,0pf7.3)')
7347      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7348 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7349 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7350                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7351      &               .or. wturn6.eq.0.0d0))then
7352 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7353                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7354                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7355      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7356 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7357 cd     &            'ecorr6=',ecorr6
7358 cd                write (iout,'(4e15.5)') sred_geom,
7359 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7360 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7361 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7362                 else if (wturn6.gt.0.0d0
7363      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7364 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7365                   eturn6=eturn6+eello_turn6(i,jj,kk)
7366                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7367      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7368 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7369                 endif
7370               ENDIF
7371 1111          continue
7372             endif
7373           enddo ! kk
7374         enddo ! jj
7375       enddo ! i
7376       do i=1,nres
7377         num_cont_hb(i)=num_cont_hb_old(i)
7378       enddo
7379 c                write (iout,*) "gradcorr5 in eello5"
7380 c                do iii=1,nres
7381 c                  write (iout,'(i5,3f10.5)')
7382 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7383 c                enddo
7384       return
7385       end
7386 c------------------------------------------------------------------------------
7387       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7388       implicit real*8 (a-h,o-z)
7389       include 'DIMENSIONS'
7390       include 'DIMENSIONS.ZSCOPT'
7391       include 'COMMON.IOUNITS'
7392       include 'COMMON.DERIV'
7393       include 'COMMON.INTERACT'
7394       include 'COMMON.CONTACTS'
7395       include 'COMMON.CONTMAT'
7396       include 'COMMON.CORRMAT'
7397       include 'COMMON.SHIELD'
7398       include 'COMMON.CONTROL'
7399       double precision gx(3),gx1(3)
7400       logical lprn
7401       lprn=.false.
7402 C      print *,"wchodze",fac_shield(i),shield_mode
7403       eij=facont_hb(jj,i)
7404       ekl=facont_hb(kk,k)
7405       ees0pij=ees0p(jj,i)
7406       ees0pkl=ees0p(kk,k)
7407       ees0mij=ees0m(jj,i)
7408       ees0mkl=ees0m(kk,k)
7409       ekont=eij*ekl
7410       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7411 C*
7412 C     & fac_shield(i)**2*fac_shield(j)**2
7413 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7414 C Following 4 lines for diagnostics.
7415 cd    ees0pkl=0.0D0
7416 cd    ees0pij=1.0D0
7417 cd    ees0mkl=0.0D0
7418 cd    ees0mij=1.0D0
7419 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7420 c     & 'Contacts ',i,j,
7421 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7422 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7423 c     & 'gradcorr_long'
7424 C Calculate the multi-body contribution to energy.
7425 C      ecorr=ecorr+ekont*ees
7426 C Calculate multi-body contributions to the gradient.
7427       coeffpees0pij=coeffp*ees0pij
7428       coeffmees0mij=coeffm*ees0mij
7429       coeffpees0pkl=coeffp*ees0pkl
7430       coeffmees0mkl=coeffm*ees0mkl
7431       do ll=1,3
7432 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7433         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7434      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7435      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7436         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7437      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7438      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7439 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7440         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7441      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7442      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7443         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7444      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7445      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7446         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7447      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7448      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7449         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7450         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7451         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7452      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7453      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7454         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7455         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7456 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7457       enddo
7458 c      write (iout,*)
7459 cgrad      do m=i+1,j-1
7460 cgrad        do ll=1,3
7461 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7462 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7463 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7464 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7465 cgrad        enddo
7466 cgrad      enddo
7467 cgrad      do m=k+1,l-1
7468 cgrad        do ll=1,3
7469 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7470 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7471 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7472 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7473 cgrad        enddo
7474 cgrad      enddo
7475 c      write (iout,*) "ehbcorr",ekont*ees
7476 C      print *,ekont,ees,i,k
7477       ehbcorr=ekont*ees
7478 C now gradient over shielding
7479 C      return
7480       if (shield_mode.gt.0) then
7481        j=ees0plist(jj,i)
7482        l=ees0plist(kk,k)
7483 C        print *,i,j,fac_shield(i),fac_shield(j),
7484 C     &fac_shield(k),fac_shield(l)
7485         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7486      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7487           do ilist=1,ishield_list(i)
7488            iresshield=shield_list(ilist,i)
7489            do m=1,3
7490            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7491 C     &      *2.0
7492            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7493      &              rlocshield
7494      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7495             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7496      &+rlocshield
7497            enddo
7498           enddo
7499           do ilist=1,ishield_list(j)
7500            iresshield=shield_list(ilist,j)
7501            do m=1,3
7502            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7503 C     &     *2.0
7504            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7505      &              rlocshield
7506      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7507            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7508      &     +rlocshield
7509            enddo
7510           enddo
7511
7512           do ilist=1,ishield_list(k)
7513            iresshield=shield_list(ilist,k)
7514            do m=1,3
7515            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7516 C     &     *2.0
7517            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7518      &              rlocshield
7519      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7520            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7521      &     +rlocshield
7522            enddo
7523           enddo
7524           do ilist=1,ishield_list(l)
7525            iresshield=shield_list(ilist,l)
7526            do m=1,3
7527            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7528 C     &     *2.0
7529            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7530      &              rlocshield
7531      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7532            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7533      &     +rlocshield
7534            enddo
7535           enddo
7536 C          print *,gshieldx(m,iresshield)
7537           do m=1,3
7538             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7539      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7540             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7541      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7542             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7543      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7544             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7545      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7546
7547             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7548      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7549             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7550      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7551             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7552      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7553             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7554      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7555
7556            enddo
7557       endif
7558       endif
7559       return
7560       end
7561 #ifdef MOMENT
7562 C---------------------------------------------------------------------------
7563       subroutine dipole(i,j,jj)
7564       implicit real*8 (a-h,o-z)
7565       include 'DIMENSIONS'
7566       include 'DIMENSIONS.ZSCOPT'
7567       include 'COMMON.IOUNITS'
7568       include 'COMMON.CHAIN'
7569       include 'COMMON.FFIELD'
7570       include 'COMMON.DERIV'
7571       include 'COMMON.INTERACT'
7572       include 'COMMON.CONTACTS'
7573       include 'COMMON.CONTMAT'
7574       include 'COMMON.CORRMAT'
7575       include 'COMMON.TORSION'
7576       include 'COMMON.VAR'
7577       include 'COMMON.GEO'
7578       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7579      &  auxmat(2,2)
7580       iti1 = itortyp(itype(i+1))
7581       if (j.lt.nres-1) then
7582         itj1 = itype2loc(itype(j+1))
7583       else
7584         itj1=nloctyp
7585       endif
7586       do iii=1,2
7587         dipi(iii,1)=Ub2(iii,i)
7588         dipderi(iii)=Ub2der(iii,i)
7589         dipi(iii,2)=b1(iii,i+1)
7590         dipj(iii,1)=Ub2(iii,j)
7591         dipderj(iii)=Ub2der(iii,j)
7592         dipj(iii,2)=b1(iii,j+1)
7593       enddo
7594       kkk=0
7595       do iii=1,2
7596         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7597         do jjj=1,2
7598           kkk=kkk+1
7599           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7600         enddo
7601       enddo
7602       do kkk=1,5
7603         do lll=1,3
7604           mmm=0
7605           do iii=1,2
7606             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7607      &        auxvec(1))
7608             do jjj=1,2
7609               mmm=mmm+1
7610               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7611             enddo
7612           enddo
7613         enddo
7614       enddo
7615       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7616       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7617       do iii=1,2
7618         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7619       enddo
7620       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7621       do iii=1,2
7622         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7623       enddo
7624       return
7625       end
7626 #endif
7627 C---------------------------------------------------------------------------
7628       subroutine calc_eello(i,j,k,l,jj,kk)
7629 C
7630 C This subroutine computes matrices and vectors needed to calculate
7631 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7632 C
7633       implicit real*8 (a-h,o-z)
7634       include 'DIMENSIONS'
7635       include 'DIMENSIONS.ZSCOPT'
7636       include 'COMMON.IOUNITS'
7637       include 'COMMON.CHAIN'
7638       include 'COMMON.DERIV'
7639       include 'COMMON.INTERACT'
7640       include 'COMMON.CONTACTS'
7641       include 'COMMON.CONTMAT'
7642       include 'COMMON.CORRMAT'
7643       include 'COMMON.TORSION'
7644       include 'COMMON.VAR'
7645       include 'COMMON.GEO'
7646       include 'COMMON.FFIELD'
7647       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7648      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7649       logical lprn
7650       common /kutas/ lprn
7651 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7652 cd     & ' jj=',jj,' kk=',kk
7653 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7654 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7655 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7656       do iii=1,2
7657         do jjj=1,2
7658           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7659           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7660         enddo
7661       enddo
7662       call transpose2(aa1(1,1),aa1t(1,1))
7663       call transpose2(aa2(1,1),aa2t(1,1))
7664       do kkk=1,5
7665         do lll=1,3
7666           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7667      &      aa1tder(1,1,lll,kkk))
7668           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7669      &      aa2tder(1,1,lll,kkk))
7670         enddo
7671       enddo
7672       if (l.eq.j+1) then
7673 C parallel orientation of the two CA-CA-CA frames.
7674         if (i.gt.1) then
7675           iti=itype2loc(itype(i))
7676         else
7677           iti=nloctyp
7678         endif
7679         itk1=itype2loc(itype(k+1))
7680         itj=itype2loc(itype(j))
7681         if (l.lt.nres-1) then
7682           itl1=itype2loc(itype(l+1))
7683         else
7684           itl1=nloctyp
7685         endif
7686 C A1 kernel(j+1) A2T
7687 cd        do iii=1,2
7688 cd          write (iout,'(3f10.5,5x,3f10.5)')
7689 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7690 cd        enddo
7691         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7692      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7693      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7694 C Following matrices are needed only for 6-th order cumulants
7695         IF (wcorr6.gt.0.0d0) THEN
7696         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7697      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7698      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7699         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7700      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7701      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7702      &   ADtEAderx(1,1,1,1,1,1))
7703         lprn=.false.
7704         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7705      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7706      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7707      &   ADtEA1derx(1,1,1,1,1,1))
7708         ENDIF
7709 C End 6-th order cumulants
7710 cd        lprn=.false.
7711 cd        if (lprn) then
7712 cd        write (2,*) 'In calc_eello6'
7713 cd        do iii=1,2
7714 cd          write (2,*) 'iii=',iii
7715 cd          do kkk=1,5
7716 cd            write (2,*) 'kkk=',kkk
7717 cd            do jjj=1,2
7718 cd              write (2,'(3(2f10.5),5x)')
7719 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7720 cd            enddo
7721 cd          enddo
7722 cd        enddo
7723 cd        endif
7724         call transpose2(EUgder(1,1,k),auxmat(1,1))
7725         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7726         call transpose2(EUg(1,1,k),auxmat(1,1))
7727         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7728         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7729         do iii=1,2
7730           do kkk=1,5
7731             do lll=1,3
7732               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7733      &          EAEAderx(1,1,lll,kkk,iii,1))
7734             enddo
7735           enddo
7736         enddo
7737 C A1T kernel(i+1) A2
7738         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7739      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7740      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7741 C Following matrices are needed only for 6-th order cumulants
7742         IF (wcorr6.gt.0.0d0) THEN
7743         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7744      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7745      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7746         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7747      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7748      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7749      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7752      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7753      &   ADtEA1derx(1,1,1,1,1,2))
7754         ENDIF
7755 C End 6-th order cumulants
7756         call transpose2(EUgder(1,1,l),auxmat(1,1))
7757         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7758         call transpose2(EUg(1,1,l),auxmat(1,1))
7759         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7760         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7761         do iii=1,2
7762           do kkk=1,5
7763             do lll=1,3
7764               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7765      &          EAEAderx(1,1,lll,kkk,iii,2))
7766             enddo
7767           enddo
7768         enddo
7769 C AEAb1 and AEAb2
7770 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7771 C They are needed only when the fifth- or the sixth-order cumulants are
7772 C indluded.
7773         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7774         call transpose2(AEA(1,1,1),auxmat(1,1))
7775         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7776         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7777         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7778         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7779         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7780         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7781         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7782         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7783         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7784         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7785         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7786         call transpose2(AEA(1,1,2),auxmat(1,1))
7787         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7788         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7789         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7790         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7791         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7792         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7793         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7794         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7795         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7796         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7797         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7798 C Calculate the Cartesian derivatives of the vectors.
7799         do iii=1,2
7800           do kkk=1,5
7801             do lll=1,3
7802               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7803               call matvec2(auxmat(1,1),b1(1,i),
7804      &          AEAb1derx(1,lll,kkk,iii,1,1))
7805               call matvec2(auxmat(1,1),Ub2(1,i),
7806      &          AEAb2derx(1,lll,kkk,iii,1,1))
7807               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7808      &          AEAb1derx(1,lll,kkk,iii,2,1))
7809               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7810      &          AEAb2derx(1,lll,kkk,iii,2,1))
7811               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7812               call matvec2(auxmat(1,1),b1(1,j),
7813      &          AEAb1derx(1,lll,kkk,iii,1,2))
7814               call matvec2(auxmat(1,1),Ub2(1,j),
7815      &          AEAb2derx(1,lll,kkk,iii,1,2))
7816               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7817      &          AEAb1derx(1,lll,kkk,iii,2,2))
7818               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7819      &          AEAb2derx(1,lll,kkk,iii,2,2))
7820             enddo
7821           enddo
7822         enddo
7823         ENDIF
7824 C End vectors
7825       else
7826 C Antiparallel orientation of the two CA-CA-CA frames.
7827         if (i.gt.1) then
7828           iti=itype2loc(itype(i))
7829         else
7830           iti=nloctyp
7831         endif
7832         itk1=itype2loc(itype(k+1))
7833         itl=itype2loc(itype(l))
7834         itj=itype2loc(itype(j))
7835         if (j.lt.nres-1) then
7836           itj1=itype2loc(itype(j+1))
7837         else
7838           itj1=nloctyp
7839         endif
7840 C A2 kernel(j-1)T A1T
7841         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7842      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7843      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7844 C Following matrices are needed only for 6-th order cumulants
7845         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7846      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7847         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7848      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7849      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7850         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7851      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7852      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7853      &   ADtEAderx(1,1,1,1,1,1))
7854         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7855      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7856      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7857      &   ADtEA1derx(1,1,1,1,1,1))
7858         ENDIF
7859 C End 6-th order cumulants
7860         call transpose2(EUgder(1,1,k),auxmat(1,1))
7861         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7862         call transpose2(EUg(1,1,k),auxmat(1,1))
7863         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7864         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7865         do iii=1,2
7866           do kkk=1,5
7867             do lll=1,3
7868               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7869      &          EAEAderx(1,1,lll,kkk,iii,1))
7870             enddo
7871           enddo
7872         enddo
7873 C A2T kernel(i+1)T A1
7874         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7875      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7876      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7877 C Following matrices are needed only for 6-th order cumulants
7878         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7879      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7880         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7881      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7882      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7883         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7884      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7885      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7886      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
7889      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7890      &   ADtEA1derx(1,1,1,1,1,2))
7891         ENDIF
7892 C End 6-th order cumulants
7893         call transpose2(EUgder(1,1,j),auxmat(1,1))
7894         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7895         call transpose2(EUg(1,1,j),auxmat(1,1))
7896         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7897         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7898         do iii=1,2
7899           do kkk=1,5
7900             do lll=1,3
7901               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7902      &          EAEAderx(1,1,lll,kkk,iii,2))
7903             enddo
7904           enddo
7905         enddo
7906 C AEAb1 and AEAb2
7907 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7908 C They are needed only when the fifth- or the sixth-order cumulants are
7909 C indluded.
7910         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7911      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7912         call transpose2(AEA(1,1,1),auxmat(1,1))
7913         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7914         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7915         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7916         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7917         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7918         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7919         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7920         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7921         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7922         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7923         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7924         call transpose2(AEA(1,1,2),auxmat(1,1))
7925         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7926         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7927         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7928         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7929         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7930         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7931         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7932         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7933         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7934         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7935         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7936 C Calculate the Cartesian derivatives of the vectors.
7937         do iii=1,2
7938           do kkk=1,5
7939             do lll=1,3
7940               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7941               call matvec2(auxmat(1,1),b1(1,i),
7942      &          AEAb1derx(1,lll,kkk,iii,1,1))
7943               call matvec2(auxmat(1,1),Ub2(1,i),
7944      &          AEAb2derx(1,lll,kkk,iii,1,1))
7945               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7946      &          AEAb1derx(1,lll,kkk,iii,2,1))
7947               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7948      &          AEAb2derx(1,lll,kkk,iii,2,1))
7949               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7950               call matvec2(auxmat(1,1),b1(1,l),
7951      &          AEAb1derx(1,lll,kkk,iii,1,2))
7952               call matvec2(auxmat(1,1),Ub2(1,l),
7953      &          AEAb2derx(1,lll,kkk,iii,1,2))
7954               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7955      &          AEAb1derx(1,lll,kkk,iii,2,2))
7956               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7957      &          AEAb2derx(1,lll,kkk,iii,2,2))
7958             enddo
7959           enddo
7960         enddo
7961         ENDIF
7962 C End vectors
7963       endif
7964       return
7965       end
7966 C---------------------------------------------------------------------------
7967       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7968      &  KK,KKderg,AKA,AKAderg,AKAderx)
7969       implicit none
7970       integer nderg
7971       logical transp
7972       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7973      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7974      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7975       integer iii,kkk,lll
7976       integer jjj,mmm
7977       logical lprn
7978       common /kutas/ lprn
7979       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7980       do iii=1,nderg
7981         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7982      &    AKAderg(1,1,iii))
7983       enddo
7984 cd      if (lprn) write (2,*) 'In kernel'
7985       do kkk=1,5
7986 cd        if (lprn) write (2,*) 'kkk=',kkk
7987         do lll=1,3
7988           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7989      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7990 cd          if (lprn) then
7991 cd            write (2,*) 'lll=',lll
7992 cd            write (2,*) 'iii=1'
7993 cd            do jjj=1,2
7994 cd              write (2,'(3(2f10.5),5x)')
7995 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7996 cd            enddo
7997 cd          endif
7998           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7999      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8000 cd          if (lprn) then
8001 cd            write (2,*) 'lll=',lll
8002 cd            write (2,*) 'iii=2'
8003 cd            do jjj=1,2
8004 cd              write (2,'(3(2f10.5),5x)')
8005 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8006 cd            enddo
8007 cd          endif
8008         enddo
8009       enddo
8010       return
8011       end
8012 C---------------------------------------------------------------------------
8013       double precision function eello4(i,j,k,l,jj,kk)
8014       implicit real*8 (a-h,o-z)
8015       include 'DIMENSIONS'
8016       include 'DIMENSIONS.ZSCOPT'
8017       include 'COMMON.IOUNITS'
8018       include 'COMMON.CHAIN'
8019       include 'COMMON.DERIV'
8020       include 'COMMON.INTERACT'
8021       include 'COMMON.CONTACTS'
8022       include 'COMMON.CONTMAT'
8023       include 'COMMON.CORRMAT'
8024       include 'COMMON.TORSION'
8025       include 'COMMON.VAR'
8026       include 'COMMON.GEO'
8027       double precision pizda(2,2),ggg1(3),ggg2(3)
8028 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8029 cd        eello4=0.0d0
8030 cd        return
8031 cd      endif
8032 cd      print *,'eello4:',i,j,k,l,jj,kk
8033 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8034 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8035 cold      eij=facont_hb(jj,i)
8036 cold      ekl=facont_hb(kk,k)
8037 cold      ekont=eij*ekl
8038       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8039       if (calc_grad) then
8040 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8041       gcorr_loc(k-1)=gcorr_loc(k-1)
8042      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8043       if (l.eq.j+1) then
8044         gcorr_loc(l-1)=gcorr_loc(l-1)
8045      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8046       else
8047         gcorr_loc(j-1)=gcorr_loc(j-1)
8048      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8049       endif
8050       do iii=1,2
8051         do kkk=1,5
8052           do lll=1,3
8053             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8054      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8055 cd            derx(lll,kkk,iii)=0.0d0
8056           enddo
8057         enddo
8058       enddo
8059 cd      gcorr_loc(l-1)=0.0d0
8060 cd      gcorr_loc(j-1)=0.0d0
8061 cd      gcorr_loc(k-1)=0.0d0
8062 cd      eel4=1.0d0
8063 cd      write (iout,*)'Contacts have occurred for peptide groups',
8064 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8065 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8066       if (j.lt.nres-1) then
8067         j1=j+1
8068         j2=j-1
8069       else
8070         j1=j-1
8071         j2=j-2
8072       endif
8073       if (l.lt.nres-1) then
8074         l1=l+1
8075         l2=l-1
8076       else
8077         l1=l-1
8078         l2=l-2
8079       endif
8080       do ll=1,3
8081 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8082 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8083         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8084         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8085 cgrad        ghalf=0.5d0*ggg1(ll)
8086         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8087         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8088         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8089         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8090         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8091         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8092 cgrad        ghalf=0.5d0*ggg2(ll)
8093         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8094         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8095         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8096         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8097         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8098         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8099       enddo
8100 cgrad      do m=i+1,j-1
8101 cgrad        do ll=1,3
8102 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8103 cgrad        enddo
8104 cgrad      enddo
8105 cgrad      do m=k+1,l-1
8106 cgrad        do ll=1,3
8107 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cgrad      do m=i+2,j2
8111 cgrad        do ll=1,3
8112 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8113 cgrad        enddo
8114 cgrad      enddo
8115 cgrad      do m=k+2,l2
8116 cgrad        do ll=1,3
8117 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8118 cgrad        enddo
8119 cgrad      enddo
8120 cd      do iii=1,nres-3
8121 cd        write (2,*) iii,gcorr_loc(iii)
8122 cd      enddo
8123       endif ! calc_grad
8124       eello4=ekont*eel4
8125 cd      write (2,*) 'ekont',ekont
8126 cd      write (iout,*) 'eello4',ekont*eel4
8127       return
8128       end
8129 C---------------------------------------------------------------------------
8130       double precision function eello5(i,j,k,l,jj,kk)
8131       implicit real*8 (a-h,o-z)
8132       include 'DIMENSIONS'
8133       include 'DIMENSIONS.ZSCOPT'
8134       include 'COMMON.IOUNITS'
8135       include 'COMMON.CHAIN'
8136       include 'COMMON.DERIV'
8137       include 'COMMON.INTERACT'
8138       include 'COMMON.CONTACTS'
8139       include 'COMMON.CONTMAT'
8140       include 'COMMON.CORRMAT'
8141       include 'COMMON.TORSION'
8142       include 'COMMON.VAR'
8143       include 'COMMON.GEO'
8144       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8145       double precision ggg1(3),ggg2(3)
8146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8147 C                                                                              C
8148 C                            Parallel chains                                   C
8149 C                                                                              C
8150 C          o             o                   o             o                   C
8151 C         /l\           / \             \   / \           / \   /              C
8152 C        /   \         /   \             \ /   \         /   \ /               C
8153 C       j| o |l1       | o |              o| o |         | o |o                C
8154 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8155 C      \i/   \         /   \ /             /   \         /   \                 C
8156 C       o    k1             o                                                  C
8157 C         (I)          (II)                (III)          (IV)                 C
8158 C                                                                              C
8159 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8160 C                                                                              C
8161 C                            Antiparallel chains                               C
8162 C                                                                              C
8163 C          o             o                   o             o                   C
8164 C         /j\           / \             \   / \           / \   /              C
8165 C        /   \         /   \             \ /   \         /   \ /               C
8166 C      j1| o |l        | o |              o| o |         | o |o                C
8167 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8168 C      \i/   \         /   \ /             /   \         /   \                 C
8169 C       o     k1            o                                                  C
8170 C         (I)          (II)                (III)          (IV)                 C
8171 C                                                                              C
8172 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8173 C                                                                              C
8174 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8175 C                                                                              C
8176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8177 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8178 cd        eello5=0.0d0
8179 cd        return
8180 cd      endif
8181 cd      write (iout,*)
8182 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8183 cd     &   ' and',k,l
8184       itk=itype2loc(itype(k))
8185       itl=itype2loc(itype(l))
8186       itj=itype2loc(itype(j))
8187       eello5_1=0.0d0
8188       eello5_2=0.0d0
8189       eello5_3=0.0d0
8190       eello5_4=0.0d0
8191 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8192 cd     &   eel5_3_num,eel5_4_num)
8193       do iii=1,2
8194         do kkk=1,5
8195           do lll=1,3
8196             derx(lll,kkk,iii)=0.0d0
8197           enddo
8198         enddo
8199       enddo
8200 cd      eij=facont_hb(jj,i)
8201 cd      ekl=facont_hb(kk,k)
8202 cd      ekont=eij*ekl
8203 cd      write (iout,*)'Contacts have occurred for peptide groups',
8204 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8205 cd      goto 1111
8206 C Contribution from the graph I.
8207 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8208 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8209       call transpose2(EUg(1,1,k),auxmat(1,1))
8210       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8211       vv(1)=pizda(1,1)-pizda(2,2)
8212       vv(2)=pizda(1,2)+pizda(2,1)
8213       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8214      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8215       if (calc_grad) then
8216 C Explicit gradient in virtual-dihedral angles.
8217       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8218      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8219      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8220       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8221       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8222       vv(1)=pizda(1,1)-pizda(2,2)
8223       vv(2)=pizda(1,2)+pizda(2,1)
8224       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8225      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8226      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8227       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8228       vv(1)=pizda(1,1)-pizda(2,2)
8229       vv(2)=pizda(1,2)+pizda(2,1)
8230       if (l.eq.j+1) then
8231         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8232      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8233      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8234       else
8235         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8236      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8237      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8238       endif
8239 C Cartesian gradient
8240       do iii=1,2
8241         do kkk=1,5
8242           do lll=1,3
8243             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8244      &        pizda(1,1))
8245             vv(1)=pizda(1,1)-pizda(2,2)
8246             vv(2)=pizda(1,2)+pizda(2,1)
8247             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8248      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8249      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8250           enddo
8251         enddo
8252       enddo
8253       endif ! calc_grad
8254 c      goto 1112
8255 c1111  continue
8256 C Contribution from graph II
8257       call transpose2(EE(1,1,k),auxmat(1,1))
8258       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8259       vv(1)=pizda(1,1)+pizda(2,2)
8260       vv(2)=pizda(2,1)-pizda(1,2)
8261       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8262      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8263       if (calc_grad) then
8264 C Explicit gradient in virtual-dihedral angles.
8265       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8266      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8267       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8268       vv(1)=pizda(1,1)+pizda(2,2)
8269       vv(2)=pizda(2,1)-pizda(1,2)
8270       if (l.eq.j+1) then
8271         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8272      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8273      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8274       else
8275         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8276      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8277      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8278       endif
8279 C Cartesian gradient
8280       do iii=1,2
8281         do kkk=1,5
8282           do lll=1,3
8283             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8284      &        pizda(1,1))
8285             vv(1)=pizda(1,1)+pizda(2,2)
8286             vv(2)=pizda(2,1)-pizda(1,2)
8287             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8288      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8289      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8290           enddo
8291         enddo
8292       enddo
8293       endif ! calc_grad
8294 cd      goto 1112
8295 cd1111  continue
8296       if (l.eq.j+1) then
8297 cd        goto 1110
8298 C Parallel orientation
8299 C Contribution from graph III
8300         call transpose2(EUg(1,1,l),auxmat(1,1))
8301         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8302         vv(1)=pizda(1,1)-pizda(2,2)
8303         vv(2)=pizda(1,2)+pizda(2,1)
8304         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8305      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8306         if (calc_grad) then
8307 C Explicit gradient in virtual-dihedral angles.
8308         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8309      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8310      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8311         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8312         vv(1)=pizda(1,1)-pizda(2,2)
8313         vv(2)=pizda(1,2)+pizda(2,1)
8314         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8315      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8316      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8317         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8318         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8319         vv(1)=pizda(1,1)-pizda(2,2)
8320         vv(2)=pizda(1,2)+pizda(2,1)
8321         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8322      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8323      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8324 C Cartesian gradient
8325         do iii=1,2
8326           do kkk=1,5
8327             do lll=1,3
8328               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8329      &          pizda(1,1))
8330               vv(1)=pizda(1,1)-pizda(2,2)
8331               vv(2)=pizda(1,2)+pizda(2,1)
8332               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8333      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8334      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8335             enddo
8336           enddo
8337         enddo
8338 cd        goto 1112
8339 C Contribution from graph IV
8340 cd1110    continue
8341         call transpose2(EE(1,1,l),auxmat(1,1))
8342         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8343         vv(1)=pizda(1,1)+pizda(2,2)
8344         vv(2)=pizda(2,1)-pizda(1,2)
8345         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8346      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8347 C Explicit gradient in virtual-dihedral angles.
8348         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8349      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8350         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8351         vv(1)=pizda(1,1)+pizda(2,2)
8352         vv(2)=pizda(2,1)-pizda(1,2)
8353         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8354      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8355      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8356 C Cartesian gradient
8357         do iii=1,2
8358           do kkk=1,5
8359             do lll=1,3
8360               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8361      &          pizda(1,1))
8362               vv(1)=pizda(1,1)+pizda(2,2)
8363               vv(2)=pizda(2,1)-pizda(1,2)
8364               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8365      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8366      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8367             enddo
8368           enddo
8369         enddo
8370         endif ! calc_grad
8371       else
8372 C Antiparallel orientation
8373 C Contribution from graph III
8374 c        goto 1110
8375         call transpose2(EUg(1,1,j),auxmat(1,1))
8376         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8377         vv(1)=pizda(1,1)-pizda(2,2)
8378         vv(2)=pizda(1,2)+pizda(2,1)
8379         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8380      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8381         if (calc_grad) then
8382 C Explicit gradient in virtual-dihedral angles.
8383         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8384      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8385      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8386         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8387         vv(1)=pizda(1,1)-pizda(2,2)
8388         vv(2)=pizda(1,2)+pizda(2,1)
8389         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8390      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8391      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8392         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8393         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8394         vv(1)=pizda(1,1)-pizda(2,2)
8395         vv(2)=pizda(1,2)+pizda(2,1)
8396         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8397      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8398      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8399 C Cartesian gradient
8400         do iii=1,2
8401           do kkk=1,5
8402             do lll=1,3
8403               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8404      &          pizda(1,1))
8405               vv(1)=pizda(1,1)-pizda(2,2)
8406               vv(2)=pizda(1,2)+pizda(2,1)
8407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8408      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8409      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8410             enddo
8411           enddo
8412         enddo
8413         endif ! calc_grad
8414 cd        goto 1112
8415 C Contribution from graph IV
8416 1110    continue
8417         call transpose2(EE(1,1,j),auxmat(1,1))
8418         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8419         vv(1)=pizda(1,1)+pizda(2,2)
8420         vv(2)=pizda(2,1)-pizda(1,2)
8421         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8422      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8423         if (calc_grad) then
8424 C Explicit gradient in virtual-dihedral angles.
8425         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8426      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8427         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8428         vv(1)=pizda(1,1)+pizda(2,2)
8429         vv(2)=pizda(2,1)-pizda(1,2)
8430         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8431      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8432      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8433 C Cartesian gradient
8434         do iii=1,2
8435           do kkk=1,5
8436             do lll=1,3
8437               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8438      &          pizda(1,1))
8439               vv(1)=pizda(1,1)+pizda(2,2)
8440               vv(2)=pizda(2,1)-pizda(1,2)
8441               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8442      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8443      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8444             enddo
8445           enddo
8446         enddo
8447         endif ! calc_grad
8448       endif
8449 1112  continue
8450       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8451 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8452 cd        write (2,*) 'ijkl',i,j,k,l
8453 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8454 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8455 cd      endif
8456 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8457 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8458 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8459 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8460       if (calc_grad) then
8461       if (j.lt.nres-1) then
8462         j1=j+1
8463         j2=j-1
8464       else
8465         j1=j-1
8466         j2=j-2
8467       endif
8468       if (l.lt.nres-1) then
8469         l1=l+1
8470         l2=l-1
8471       else
8472         l1=l-1
8473         l2=l-2
8474       endif
8475 cd      eij=1.0d0
8476 cd      ekl=1.0d0
8477 cd      ekont=1.0d0
8478 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8479 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8480 C        summed up outside the subrouine as for the other subroutines
8481 C        handling long-range interactions. The old code is commented out
8482 C        with "cgrad" to keep track of changes.
8483       do ll=1,3
8484 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8485 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8486         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8487         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8488 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8489 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8490 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8491 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8492 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8493 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8494 c     &   gradcorr5ij,
8495 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8496 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8497 cgrad        ghalf=0.5d0*ggg1(ll)
8498 cd        ghalf=0.0d0
8499         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8500         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8501         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8502         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8503         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8504         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8505 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8506 cgrad        ghalf=0.5d0*ggg2(ll)
8507 cd        ghalf=0.0d0
8508         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8509         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8510         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8511         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8512         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8513         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8514       enddo
8515       endif ! calc_grad
8516 cd      goto 1112
8517 cgrad      do m=i+1,j-1
8518 cgrad        do ll=1,3
8519 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8520 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8521 cgrad        enddo
8522 cgrad      enddo
8523 cgrad      do m=k+1,l-1
8524 cgrad        do ll=1,3
8525 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8526 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8527 cgrad        enddo
8528 cgrad      enddo
8529 c1112  continue
8530 cgrad      do m=i+2,j2
8531 cgrad        do ll=1,3
8532 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8533 cgrad        enddo
8534 cgrad      enddo
8535 cgrad      do m=k+2,l2
8536 cgrad        do ll=1,3
8537 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8538 cgrad        enddo
8539 cgrad      enddo
8540 cd      do iii=1,nres-3
8541 cd        write (2,*) iii,g_corr5_loc(iii)
8542 cd      enddo
8543       eello5=ekont*eel5
8544 cd      write (2,*) 'ekont',ekont
8545 cd      write (iout,*) 'eello5',ekont*eel5
8546       return
8547       end
8548 c--------------------------------------------------------------------------
8549       double precision function eello6(i,j,k,l,jj,kk)
8550       implicit real*8 (a-h,o-z)
8551       include 'DIMENSIONS'
8552       include 'DIMENSIONS.ZSCOPT'
8553       include 'COMMON.IOUNITS'
8554       include 'COMMON.CHAIN'
8555       include 'COMMON.DERIV'
8556       include 'COMMON.INTERACT'
8557       include 'COMMON.CONTACTS'
8558       include 'COMMON.CONTMAT'
8559       include 'COMMON.CORRMAT'
8560       include 'COMMON.TORSION'
8561       include 'COMMON.VAR'
8562       include 'COMMON.GEO'
8563       include 'COMMON.FFIELD'
8564       double precision ggg1(3),ggg2(3)
8565 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8566 cd        eello6=0.0d0
8567 cd        return
8568 cd      endif
8569 cd      write (iout,*)
8570 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8571 cd     &   ' and',k,l
8572       eello6_1=0.0d0
8573       eello6_2=0.0d0
8574       eello6_3=0.0d0
8575       eello6_4=0.0d0
8576       eello6_5=0.0d0
8577       eello6_6=0.0d0
8578 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8579 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8580       do iii=1,2
8581         do kkk=1,5
8582           do lll=1,3
8583             derx(lll,kkk,iii)=0.0d0
8584           enddo
8585         enddo
8586       enddo
8587 cd      eij=facont_hb(jj,i)
8588 cd      ekl=facont_hb(kk,k)
8589 cd      ekont=eij*ekl
8590 cd      eij=1.0d0
8591 cd      ekl=1.0d0
8592 cd      ekont=1.0d0
8593       if (l.eq.j+1) then
8594         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8595         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8596         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8597         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8598         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8599         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8600       else
8601         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8602         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8603         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8604         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8605         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8606           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8607         else
8608           eello6_5=0.0d0
8609         endif
8610         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8611       endif
8612 C If turn contributions are considered, they will be handled separately.
8613       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8614 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8615 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8616 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8617 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8618 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8619 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8620 cd      goto 1112
8621       if (calc_grad) then
8622       if (j.lt.nres-1) then
8623         j1=j+1
8624         j2=j-1
8625       else
8626         j1=j-1
8627         j2=j-2
8628       endif
8629       if (l.lt.nres-1) then
8630         l1=l+1
8631         l2=l-1
8632       else
8633         l1=l-1
8634         l2=l-2
8635       endif
8636       do ll=1,3
8637 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8638 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8639 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8640 cgrad        ghalf=0.5d0*ggg1(ll)
8641 cd        ghalf=0.0d0
8642         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8643         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8644         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8645         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8646         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8647         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8648         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8649         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8650 cgrad        ghalf=0.5d0*ggg2(ll)
8651 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8652 cd        ghalf=0.0d0
8653         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8654         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8655         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8656         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8657         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8658         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8659       enddo
8660       endif ! calc_grad
8661 cd      goto 1112
8662 cgrad      do m=i+1,j-1
8663 cgrad        do ll=1,3
8664 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8665 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8666 cgrad        enddo
8667 cgrad      enddo
8668 cgrad      do m=k+1,l-1
8669 cgrad        do ll=1,3
8670 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8671 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8672 cgrad        enddo
8673 cgrad      enddo
8674 cgrad1112  continue
8675 cgrad      do m=i+2,j2
8676 cgrad        do ll=1,3
8677 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8678 cgrad        enddo
8679 cgrad      enddo
8680 cgrad      do m=k+2,l2
8681 cgrad        do ll=1,3
8682 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8683 cgrad        enddo
8684 cgrad      enddo
8685 cd      do iii=1,nres-3
8686 cd        write (2,*) iii,g_corr6_loc(iii)
8687 cd      enddo
8688       eello6=ekont*eel6
8689 cd      write (2,*) 'ekont',ekont
8690 cd      write (iout,*) 'eello6',ekont*eel6
8691       return
8692       end
8693 c--------------------------------------------------------------------------
8694       double precision function eello6_graph1(i,j,k,l,imat,swap)
8695       implicit real*8 (a-h,o-z)
8696       include 'DIMENSIONS'
8697       include 'DIMENSIONS.ZSCOPT'
8698       include 'COMMON.IOUNITS'
8699       include 'COMMON.CHAIN'
8700       include 'COMMON.DERIV'
8701       include 'COMMON.INTERACT'
8702       include 'COMMON.CONTACTS'
8703       include 'COMMON.CONTMAT'
8704       include 'COMMON.CORRMAT'
8705       include 'COMMON.TORSION'
8706       include 'COMMON.VAR'
8707       include 'COMMON.GEO'
8708       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8709       logical swap
8710       logical lprn
8711       common /kutas/ lprn
8712 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8713 C                                                                              C
8714 C      Parallel       Antiparallel                                             C
8715 C                                                                              C
8716 C          o             o                                                     C
8717 C         /l\           /j\                                                    C
8718 C        /   \         /   \                                                   C
8719 C       /| o |         | o |\                                                  C
8720 C     \ j|/k\|  /   \  |/k\|l /                                                C
8721 C      \ /   \ /     \ /   \ /                                                 C
8722 C       o     o       o     o                                                  C
8723 C       i             i                                                        C
8724 C                                                                              C
8725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8726       itk=itype2loc(itype(k))
8727       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8728       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8729       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8730       call transpose2(EUgC(1,1,k),auxmat(1,1))
8731       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8732       vv1(1)=pizda1(1,1)-pizda1(2,2)
8733       vv1(2)=pizda1(1,2)+pizda1(2,1)
8734       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8735       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8736       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8737       s5=scalar2(vv(1),Dtobr2(1,i))
8738 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8739       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8740       if (calc_grad) then
8741       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8742      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8743      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8744      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8745      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8746      & +scalar2(vv(1),Dtobr2der(1,i)))
8747       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8748       vv1(1)=pizda1(1,1)-pizda1(2,2)
8749       vv1(2)=pizda1(1,2)+pizda1(2,1)
8750       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8751       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8752       if (l.eq.j+1) then
8753         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8754      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8755      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8756      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8757      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8758       else
8759         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8760      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8761      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8762      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8763      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8764       endif
8765       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8766       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8767       vv1(1)=pizda1(1,1)-pizda1(2,2)
8768       vv1(2)=pizda1(1,2)+pizda1(2,1)
8769       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8770      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8771      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8772      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8773       do iii=1,2
8774         if (swap) then
8775           ind=3-iii
8776         else
8777           ind=iii
8778         endif
8779         do kkk=1,5
8780           do lll=1,3
8781             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8782             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8783             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8784             call transpose2(EUgC(1,1,k),auxmat(1,1))
8785             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8786      &        pizda1(1,1))
8787             vv1(1)=pizda1(1,1)-pizda1(2,2)
8788             vv1(2)=pizda1(1,2)+pizda1(2,1)
8789             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8790             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8791      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8792             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8793      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8794             s5=scalar2(vv(1),Dtobr2(1,i))
8795             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8796           enddo
8797         enddo
8798       enddo
8799       endif ! calc_grad
8800       return
8801       end
8802 c----------------------------------------------------------------------------
8803       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8804       implicit real*8 (a-h,o-z)
8805       include 'DIMENSIONS'
8806       include 'DIMENSIONS.ZSCOPT'
8807       include 'COMMON.IOUNITS'
8808       include 'COMMON.CHAIN'
8809       include 'COMMON.DERIV'
8810       include 'COMMON.INTERACT'
8811       include 'COMMON.CONTACTS'
8812       include 'COMMON.CONTMAT'
8813       include 'COMMON.CORRMAT'
8814       include 'COMMON.TORSION'
8815       include 'COMMON.VAR'
8816       include 'COMMON.GEO'
8817       logical swap
8818       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8819      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8820       logical lprn
8821       common /kutas/ lprn
8822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8823 C                                                                              C
8824 C      Parallel       Antiparallel                                             C
8825 C                                                                              C
8826 C          o             o                                                     C
8827 C     \   /l\           /j\   /                                                C
8828 C      \ /   \         /   \ /                                                 C
8829 C       o| o |         | o |o                                                  C
8830 C     \ j|/k\|      \  |/k\|l                                                  C
8831 C      \ /   \       \ /   \                                                   C
8832 C       o             o                                                        C
8833 C       i             i                                                        C
8834 C                                                                              C
8835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8836 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8837 C AL 7/4/01 s1 would occur in the sixth-order moment,
8838 C           but not in a cluster cumulant
8839 #ifdef MOMENT
8840       s1=dip(1,jj,i)*dip(1,kk,k)
8841 #endif
8842       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8843       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8844       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8845       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8846       call transpose2(EUg(1,1,k),auxmat(1,1))
8847       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8848       vv(1)=pizda(1,1)-pizda(2,2)
8849       vv(2)=pizda(1,2)+pizda(2,1)
8850       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8851 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8852 #ifdef MOMENT
8853       eello6_graph2=-(s1+s2+s3+s4)
8854 #else
8855       eello6_graph2=-(s2+s3+s4)
8856 #endif
8857 c      eello6_graph2=-s3
8858 C Derivatives in gamma(i-1)
8859       if (calc_grad) then
8860       if (i.gt.1) then
8861 #ifdef MOMENT
8862         s1=dipderg(1,jj,i)*dip(1,kk,k)
8863 #endif
8864         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8865         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8866         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8867         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8868 #ifdef MOMENT
8869         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8870 #else
8871         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8872 #endif
8873 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8874       endif
8875 C Derivatives in gamma(k-1)
8876 #ifdef MOMENT
8877       s1=dip(1,jj,i)*dipderg(1,kk,k)
8878 #endif
8879       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8880       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8881       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8882       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8883       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8884       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8885       vv(1)=pizda(1,1)-pizda(2,2)
8886       vv(2)=pizda(1,2)+pizda(2,1)
8887       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8888 #ifdef MOMENT
8889       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8890 #else
8891       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8892 #endif
8893 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8894 C Derivatives in gamma(j-1) or gamma(l-1)
8895       if (j.gt.1) then
8896 #ifdef MOMENT
8897         s1=dipderg(3,jj,i)*dip(1,kk,k)
8898 #endif
8899         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8900         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8901         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8902         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8903         vv(1)=pizda(1,1)-pizda(2,2)
8904         vv(2)=pizda(1,2)+pizda(2,1)
8905         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8906 #ifdef MOMENT
8907         if (swap) then
8908           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8909         else
8910           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8911         endif
8912 #endif
8913         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8914 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8915       endif
8916 C Derivatives in gamma(l-1) or gamma(j-1)
8917       if (l.gt.1) then
8918 #ifdef MOMENT
8919         s1=dip(1,jj,i)*dipderg(3,kk,k)
8920 #endif
8921         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8922         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8923         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8924         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8925         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8926         vv(1)=pizda(1,1)-pizda(2,2)
8927         vv(2)=pizda(1,2)+pizda(2,1)
8928         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8929 #ifdef MOMENT
8930         if (swap) then
8931           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8932         else
8933           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8934         endif
8935 #endif
8936         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8937 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8938       endif
8939 C Cartesian derivatives.
8940       if (lprn) then
8941         write (2,*) 'In eello6_graph2'
8942         do iii=1,2
8943           write (2,*) 'iii=',iii
8944           do kkk=1,5
8945             write (2,*) 'kkk=',kkk
8946             do jjj=1,2
8947               write (2,'(3(2f10.5),5x)')
8948      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8949             enddo
8950           enddo
8951         enddo
8952       endif
8953       do iii=1,2
8954         do kkk=1,5
8955           do lll=1,3
8956 #ifdef MOMENT
8957             if (iii.eq.1) then
8958               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8959             else
8960               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8961             endif
8962 #endif
8963             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8964      &        auxvec(1))
8965             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8966             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8967      &        auxvec(1))
8968             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8969             call transpose2(EUg(1,1,k),auxmat(1,1))
8970             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8971      &        pizda(1,1))
8972             vv(1)=pizda(1,1)-pizda(2,2)
8973             vv(2)=pizda(1,2)+pizda(2,1)
8974             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8975 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8976 #ifdef MOMENT
8977             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8978 #else
8979             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8980 #endif
8981             if (swap) then
8982               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8983             else
8984               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8985             endif
8986           enddo
8987         enddo
8988       enddo
8989       endif ! calc_grad
8990       return
8991       end
8992 c----------------------------------------------------------------------------
8993       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8994       implicit real*8 (a-h,o-z)
8995       include 'DIMENSIONS'
8996       include 'DIMENSIONS.ZSCOPT'
8997       include 'COMMON.IOUNITS'
8998       include 'COMMON.CHAIN'
8999       include 'COMMON.DERIV'
9000       include 'COMMON.INTERACT'
9001       include 'COMMON.CONTACTS'
9002       include 'COMMON.CONTMAT'
9003       include 'COMMON.CORRMAT'
9004       include 'COMMON.TORSION'
9005       include 'COMMON.VAR'
9006       include 'COMMON.GEO'
9007       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9008       logical swap
9009 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9010 C                                                                              C
9011 C      Parallel       Antiparallel                                             C
9012 C                                                                              C
9013 C          o             o                                                     C
9014 C         /l\   /   \   /j\                                                    C
9015 C        /   \ /     \ /   \                                                   C
9016 C       /| o |o       o| o |\                                                  C
9017 C       j|/k\|  /      |/k\|l /                                                C
9018 C        /   \ /       /   \ /                                                 C
9019 C       /     o       /     o                                                  C
9020 C       i             i                                                        C
9021 C                                                                              C
9022 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9023 C
9024 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9025 C           energy moment and not to the cluster cumulant.
9026       iti=itortyp(itype(i))
9027       if (j.lt.nres-1) then
9028         itj1=itype2loc(itype(j+1))
9029       else
9030         itj1=nloctyp
9031       endif
9032       itk=itype2loc(itype(k))
9033       itk1=itype2loc(itype(k+1))
9034       if (l.lt.nres-1) then
9035         itl1=itype2loc(itype(l+1))
9036       else
9037         itl1=nloctyp
9038       endif
9039 #ifdef MOMENT
9040       s1=dip(4,jj,i)*dip(4,kk,k)
9041 #endif
9042       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9043       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9044       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9045       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9046       call transpose2(EE(1,1,k),auxmat(1,1))
9047       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9048       vv(1)=pizda(1,1)+pizda(2,2)
9049       vv(2)=pizda(2,1)-pizda(1,2)
9050       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9051 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9052 cd     & "sum",-(s2+s3+s4)
9053 #ifdef MOMENT
9054       eello6_graph3=-(s1+s2+s3+s4)
9055 #else
9056       eello6_graph3=-(s2+s3+s4)
9057 #endif
9058 c      eello6_graph3=-s4
9059 C Derivatives in gamma(k-1)
9060       if (calc_grad) then
9061       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9062       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9063       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9064       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9065 C Derivatives in gamma(l-1)
9066       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9067       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9068       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9069       vv(1)=pizda(1,1)+pizda(2,2)
9070       vv(2)=pizda(2,1)-pizda(1,2)
9071       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9072       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9073 C Cartesian derivatives.
9074       do iii=1,2
9075         do kkk=1,5
9076           do lll=1,3
9077 #ifdef MOMENT
9078             if (iii.eq.1) then
9079               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9080             else
9081               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9082             endif
9083 #endif
9084             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9085      &        auxvec(1))
9086             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9087             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9088      &        auxvec(1))
9089             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9090             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9091      &        pizda(1,1))
9092             vv(1)=pizda(1,1)+pizda(2,2)
9093             vv(2)=pizda(2,1)-pizda(1,2)
9094             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9095 #ifdef MOMENT
9096             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9097 #else
9098             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9099 #endif
9100             if (swap) then
9101               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9102             else
9103               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9104             endif
9105 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9106           enddo
9107         enddo
9108       enddo
9109       endif ! calc_grad
9110       return
9111       end
9112 c----------------------------------------------------------------------------
9113       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9114       implicit real*8 (a-h,o-z)
9115       include 'DIMENSIONS'
9116       include 'DIMENSIONS.ZSCOPT'
9117       include 'COMMON.IOUNITS'
9118       include 'COMMON.CHAIN'
9119       include 'COMMON.DERIV'
9120       include 'COMMON.INTERACT'
9121       include 'COMMON.CONTACTS'
9122       include 'COMMON.CONTMAT'
9123       include 'COMMON.CORRMAT'
9124       include 'COMMON.TORSION'
9125       include 'COMMON.VAR'
9126       include 'COMMON.GEO'
9127       include 'COMMON.FFIELD'
9128       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9129      & auxvec1(2),auxmat1(2,2)
9130       logical swap
9131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9132 C                                                                              C
9133 C      Parallel       Antiparallel                                             C
9134 C                                                                              C
9135 C          o             o                                                     C
9136 C         /l\   /   \   /j\                                                    C
9137 C        /   \ /     \ /   \                                                   C
9138 C       /| o |o       o| o |\                                                  C
9139 C     \ j|/k\|      \  |/k\|l                                                  C
9140 C      \ /   \       \ /   \                                                   C
9141 C       o     \       o     \                                                  C
9142 C       i             i                                                        C
9143 C                                                                              C
9144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9145 C
9146 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9147 C           energy moment and not to the cluster cumulant.
9148 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9149       iti=itype2loc(itype(i))
9150       itj=itype2loc(itype(j))
9151       if (j.lt.nres-1) then
9152         itj1=itype2loc(itype(j+1))
9153       else
9154         itj1=nloctyp
9155       endif
9156       itk=itype2loc(itype(k))
9157       if (k.lt.nres-1) then
9158         itk1=itype2loc(itype(k+1))
9159       else
9160         itk1=nloctyp
9161       endif
9162       itl=itype2loc(itype(l))
9163       if (l.lt.nres-1) then
9164         itl1=itype2loc(itype(l+1))
9165       else
9166         itl1=nloctyp
9167       endif
9168 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9169 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9170 cd     & ' itl',itl,' itl1',itl1
9171 #ifdef MOMENT
9172       if (imat.eq.1) then
9173         s1=dip(3,jj,i)*dip(3,kk,k)
9174       else
9175         s1=dip(2,jj,j)*dip(2,kk,l)
9176       endif
9177 #endif
9178       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9179       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9180       if (j.eq.l+1) then
9181         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9182         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9183       else
9184         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9185         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9186       endif
9187       call transpose2(EUg(1,1,k),auxmat(1,1))
9188       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9189       vv(1)=pizda(1,1)-pizda(2,2)
9190       vv(2)=pizda(2,1)+pizda(1,2)
9191       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9192 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9193 #ifdef MOMENT
9194       eello6_graph4=-(s1+s2+s3+s4)
9195 #else
9196       eello6_graph4=-(s2+s3+s4)
9197 #endif
9198 C Derivatives in gamma(i-1)
9199       if (calc_grad) then
9200       if (i.gt.1) then
9201 #ifdef MOMENT
9202         if (imat.eq.1) then
9203           s1=dipderg(2,jj,i)*dip(3,kk,k)
9204         else
9205           s1=dipderg(4,jj,j)*dip(2,kk,l)
9206         endif
9207 #endif
9208         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9209         if (j.eq.l+1) then
9210           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9211           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9212         else
9213           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9214           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9215         endif
9216         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9217         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9218 cd          write (2,*) 'turn6 derivatives'
9219 #ifdef MOMENT
9220           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9221 #else
9222           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9223 #endif
9224         else
9225 #ifdef MOMENT
9226           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9227 #else
9228           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9229 #endif
9230         endif
9231       endif
9232 C Derivatives in gamma(k-1)
9233 #ifdef MOMENT
9234       if (imat.eq.1) then
9235         s1=dip(3,jj,i)*dipderg(2,kk,k)
9236       else
9237         s1=dip(2,jj,j)*dipderg(4,kk,l)
9238       endif
9239 #endif
9240       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9241       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9242       if (j.eq.l+1) then
9243         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9244         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9245       else
9246         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9247         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9248       endif
9249       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9250       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9251       vv(1)=pizda(1,1)-pizda(2,2)
9252       vv(2)=pizda(2,1)+pizda(1,2)
9253       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9254       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9255 #ifdef MOMENT
9256         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9257 #else
9258         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9259 #endif
9260       else
9261 #ifdef MOMENT
9262         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9263 #else
9264         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9265 #endif
9266       endif
9267 C Derivatives in gamma(j-1) or gamma(l-1)
9268       if (l.eq.j+1 .and. l.gt.1) then
9269         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9270         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9271         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9272         vv(1)=pizda(1,1)-pizda(2,2)
9273         vv(2)=pizda(2,1)+pizda(1,2)
9274         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9275         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9276       else if (j.gt.1) then
9277         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9278         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9279         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9280         vv(1)=pizda(1,1)-pizda(2,2)
9281         vv(2)=pizda(2,1)+pizda(1,2)
9282         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9283         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9284           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9285         else
9286           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9287         endif
9288       endif
9289 C Cartesian derivatives.
9290       do iii=1,2
9291         do kkk=1,5
9292           do lll=1,3
9293 #ifdef MOMENT
9294             if (iii.eq.1) then
9295               if (imat.eq.1) then
9296                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9297               else
9298                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9299               endif
9300             else
9301               if (imat.eq.1) then
9302                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9303               else
9304                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9305               endif
9306             endif
9307 #endif
9308             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9309      &        auxvec(1))
9310             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9311             if (j.eq.l+1) then
9312               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9313      &          b1(1,j+1),auxvec(1))
9314               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9315             else
9316               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9317      &          b1(1,l+1),auxvec(1))
9318               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9319             endif
9320             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9321      &        pizda(1,1))
9322             vv(1)=pizda(1,1)-pizda(2,2)
9323             vv(2)=pizda(2,1)+pizda(1,2)
9324             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9325             if (swap) then
9326               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9327 #ifdef MOMENT
9328                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9329      &             -(s1+s2+s4)
9330 #else
9331                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9332      &             -(s2+s4)
9333 #endif
9334                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9335               else
9336 #ifdef MOMENT
9337                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9338 #else
9339                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9340 #endif
9341                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9342               endif
9343             else
9344 #ifdef MOMENT
9345               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9346 #else
9347               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9348 #endif
9349               if (l.eq.j+1) then
9350                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9351               else
9352                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9353               endif
9354             endif
9355           enddo
9356         enddo
9357       enddo
9358       endif ! calc_grad
9359       return
9360       end
9361 c----------------------------------------------------------------------------
9362       double precision function eello_turn6(i,jj,kk)
9363       implicit real*8 (a-h,o-z)
9364       include 'DIMENSIONS'
9365       include 'DIMENSIONS.ZSCOPT'
9366       include 'COMMON.IOUNITS'
9367       include 'COMMON.CHAIN'
9368       include 'COMMON.DERIV'
9369       include 'COMMON.INTERACT'
9370       include 'COMMON.CONTACTS'
9371       include 'COMMON.CONTMAT'
9372       include 'COMMON.CORRMAT'
9373       include 'COMMON.TORSION'
9374       include 'COMMON.VAR'
9375       include 'COMMON.GEO'
9376       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9377      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9378      &  ggg1(3),ggg2(3)
9379       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9380      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9381 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9382 C           the respective energy moment and not to the cluster cumulant.
9383       s1=0.0d0
9384       s8=0.0d0
9385       s13=0.0d0
9386 c
9387       eello_turn6=0.0d0
9388       j=i+4
9389       k=i+1
9390       l=i+3
9391       iti=itype2loc(itype(i))
9392       itk=itype2loc(itype(k))
9393       itk1=itype2loc(itype(k+1))
9394       itl=itype2loc(itype(l))
9395       itj=itype2loc(itype(j))
9396 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9397 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9398 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9399 cd        eello6=0.0d0
9400 cd        return
9401 cd      endif
9402 cd      write (iout,*)
9403 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9404 cd     &   ' and',k,l
9405 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9406       do iii=1,2
9407         do kkk=1,5
9408           do lll=1,3
9409             derx_turn(lll,kkk,iii)=0.0d0
9410           enddo
9411         enddo
9412       enddo
9413 cd      eij=1.0d0
9414 cd      ekl=1.0d0
9415 cd      ekont=1.0d0
9416       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9417 cd      eello6_5=0.0d0
9418 cd      write (2,*) 'eello6_5',eello6_5
9419 #ifdef MOMENT
9420       call transpose2(AEA(1,1,1),auxmat(1,1))
9421       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9422       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9423       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9424 #endif
9425       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9426       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9427       s2 = scalar2(b1(1,k),vtemp1(1))
9428 #ifdef MOMENT
9429       call transpose2(AEA(1,1,2),atemp(1,1))
9430       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9431       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9432       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9433 #endif
9434       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9435       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9436       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9437 #ifdef MOMENT
9438       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9439       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9440       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9441       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9442       ss13 = scalar2(b1(1,k),vtemp4(1))
9443       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9444 #endif
9445 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9446 c      s1=0.0d0
9447 c      s2=0.0d0
9448 c      s8=0.0d0
9449 c      s12=0.0d0
9450 c      s13=0.0d0
9451       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9452 C Derivatives in gamma(i+2)
9453       if (calc_grad) then
9454       s1d =0.0d0
9455       s8d =0.0d0
9456 #ifdef MOMENT
9457       call transpose2(AEA(1,1,1),auxmatd(1,1))
9458       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9459       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9460       call transpose2(AEAderg(1,1,2),atempd(1,1))
9461       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9462       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9463 #endif
9464       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9465       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9466       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9467 c      s1d=0.0d0
9468 c      s2d=0.0d0
9469 c      s8d=0.0d0
9470 c      s12d=0.0d0
9471 c      s13d=0.0d0
9472       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9473 C Derivatives in gamma(i+3)
9474 #ifdef MOMENT
9475       call transpose2(AEA(1,1,1),auxmatd(1,1))
9476       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9477       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9478       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9479 #endif
9480       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9481       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9482       s2d = scalar2(b1(1,k),vtemp1d(1))
9483 #ifdef MOMENT
9484       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9485       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9486 #endif
9487       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9488 #ifdef MOMENT
9489       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9490       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9491       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9492 #endif
9493 c      s1d=0.0d0
9494 c      s2d=0.0d0
9495 c      s8d=0.0d0
9496 c      s12d=0.0d0
9497 c      s13d=0.0d0
9498 #ifdef MOMENT
9499       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9500      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9501 #else
9502       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9503      &               -0.5d0*ekont*(s2d+s12d)
9504 #endif
9505 C Derivatives in gamma(i+4)
9506       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9507       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9508       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9509 #ifdef MOMENT
9510       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9511       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9512       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9513 #endif
9514 c      s1d=0.0d0
9515 c      s2d=0.0d0
9516 c      s8d=0.0d0
9517 C      s12d=0.0d0
9518 c      s13d=0.0d0
9519 #ifdef MOMENT
9520       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9521 #else
9522       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9523 #endif
9524 C Derivatives in gamma(i+5)
9525 #ifdef MOMENT
9526       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9527       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9528       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9529 #endif
9530       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9531       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9532       s2d = scalar2(b1(1,k),vtemp1d(1))
9533 #ifdef MOMENT
9534       call transpose2(AEA(1,1,2),atempd(1,1))
9535       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9536       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9537 #endif
9538       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9539       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9540 #ifdef MOMENT
9541       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9542       ss13d = scalar2(b1(1,k),vtemp4d(1))
9543       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9544 #endif
9545 c      s1d=0.0d0
9546 c      s2d=0.0d0
9547 c      s8d=0.0d0
9548 c      s12d=0.0d0
9549 c      s13d=0.0d0
9550 #ifdef MOMENT
9551       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9552      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9553 #else
9554       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9555      &               -0.5d0*ekont*(s2d+s12d)
9556 #endif
9557 C Cartesian derivatives
9558       do iii=1,2
9559         do kkk=1,5
9560           do lll=1,3
9561 #ifdef MOMENT
9562             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9563             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9564             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9565 #endif
9566             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9567             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9568      &          vtemp1d(1))
9569             s2d = scalar2(b1(1,k),vtemp1d(1))
9570 #ifdef MOMENT
9571             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9572             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9573             s8d = -(atempd(1,1)+atempd(2,2))*
9574      &           scalar2(cc(1,1,l),vtemp2(1))
9575 #endif
9576             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9577      &           auxmatd(1,1))
9578             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9579             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9580 c      s1d=0.0d0
9581 c      s2d=0.0d0
9582 c      s8d=0.0d0
9583 c      s12d=0.0d0
9584 c      s13d=0.0d0
9585 #ifdef MOMENT
9586             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9587      &        - 0.5d0*(s1d+s2d)
9588 #else
9589             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9590      &        - 0.5d0*s2d
9591 #endif
9592 #ifdef MOMENT
9593             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9594      &        - 0.5d0*(s8d+s12d)
9595 #else
9596             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9597      &        - 0.5d0*s12d
9598 #endif
9599           enddo
9600         enddo
9601       enddo
9602 #ifdef MOMENT
9603       do kkk=1,5
9604         do lll=1,3
9605           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9606      &      achuj_tempd(1,1))
9607           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9608           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9609           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9610           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9611           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9612      &      vtemp4d(1))
9613           ss13d = scalar2(b1(1,k),vtemp4d(1))
9614           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9615           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9616         enddo
9617       enddo
9618 #endif
9619 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9620 cd     &  16*eel_turn6_num
9621 cd      goto 1112
9622       if (j.lt.nres-1) then
9623         j1=j+1
9624         j2=j-1
9625       else
9626         j1=j-1
9627         j2=j-2
9628       endif
9629       if (l.lt.nres-1) then
9630         l1=l+1
9631         l2=l-1
9632       else
9633         l1=l-1
9634         l2=l-2
9635       endif
9636       do ll=1,3
9637 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9638 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9639 cgrad        ghalf=0.5d0*ggg1(ll)
9640 cd        ghalf=0.0d0
9641         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9642         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9643         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9644      &    +ekont*derx_turn(ll,2,1)
9645         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9646         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9647      &    +ekont*derx_turn(ll,4,1)
9648         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9649         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9650         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9651 cgrad        ghalf=0.5d0*ggg2(ll)
9652 cd        ghalf=0.0d0
9653         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9654      &    +ekont*derx_turn(ll,2,2)
9655         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9656         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9657      &    +ekont*derx_turn(ll,4,2)
9658         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9659         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9660         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9661       enddo
9662 cd      goto 1112
9663 cgrad      do m=i+1,j-1
9664 cgrad        do ll=1,3
9665 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9666 cgrad        enddo
9667 cgrad      enddo
9668 cgrad      do m=k+1,l-1
9669 cgrad        do ll=1,3
9670 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9671 cgrad        enddo
9672 cgrad      enddo
9673 cgrad1112  continue
9674 cgrad      do m=i+2,j2
9675 cgrad        do ll=1,3
9676 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9677 cgrad        enddo
9678 cgrad      enddo
9679 cgrad      do m=k+2,l2
9680 cgrad        do ll=1,3
9681 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9682 cgrad        enddo
9683 cgrad      enddo
9684 cd      do iii=1,nres-3
9685 cd        write (2,*) iii,g_corr6_loc(iii)
9686 cd      enddo
9687       endif ! calc_grad
9688       eello_turn6=ekont*eel_turn6
9689 cd      write (2,*) 'ekont',ekont
9690 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9691       return
9692       end
9693 #endif
9694 crc-------------------------------------------------
9695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9696       subroutine Eliptransfer(eliptran)
9697       implicit real*8 (a-h,o-z)
9698       include 'DIMENSIONS'
9699       include 'DIMENSIONS.ZSCOPT'
9700       include 'COMMON.GEO'
9701       include 'COMMON.VAR'
9702       include 'COMMON.LOCAL'
9703       include 'COMMON.CHAIN'
9704       include 'COMMON.DERIV'
9705       include 'COMMON.INTERACT'
9706       include 'COMMON.IOUNITS'
9707       include 'COMMON.CALC'
9708       include 'COMMON.CONTROL'
9709       include 'COMMON.SPLITELE'
9710       include 'COMMON.SBRIDGE'
9711 C this is done by Adasko
9712 C      print *,"wchodze"
9713 C structure of box:
9714 C      water
9715 C--bordliptop-- buffore starts
9716 C--bufliptop--- here true lipid starts
9717 C      lipid
9718 C--buflipbot--- lipid ends buffore starts
9719 C--bordlipbot--buffore ends
9720       eliptran=0.0
9721       do i=1,nres
9722 C       do i=1,1
9723         if (itype(i).eq.ntyp1) cycle
9724
9725         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9726         if (positi.le.0) positi=positi+boxzsize
9727 C        print *,i
9728 C first for peptide groups
9729 c for each residue check if it is in lipid or lipid water border area
9730        if ((positi.gt.bordlipbot)
9731      &.and.(positi.lt.bordliptop)) then
9732 C the energy transfer exist
9733         if (positi.lt.buflipbot) then
9734 C what fraction I am in
9735          fracinbuf=1.0d0-
9736      &        ((positi-bordlipbot)/lipbufthick)
9737 C lipbufthick is thickenes of lipid buffore
9738          sslip=sscalelip(fracinbuf)
9739          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9740          eliptran=eliptran+sslip*pepliptran
9741          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9742          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9743 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9744         elseif (positi.gt.bufliptop) then
9745          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9746          sslip=sscalelip(fracinbuf)
9747          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9748          eliptran=eliptran+sslip*pepliptran
9749          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9750          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9751 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9752 C          print *, "doing sscalefor top part"
9753 C         print *,i,sslip,fracinbuf,ssgradlip
9754         else
9755          eliptran=eliptran+pepliptran
9756 C         print *,"I am in true lipid"
9757         endif
9758 C       else
9759 C       eliptran=elpitran+0.0 ! I am in water
9760        endif
9761        enddo
9762 C       print *, "nic nie bylo w lipidzie?"
9763 C now multiply all by the peptide group transfer factor
9764 C       eliptran=eliptran*pepliptran
9765 C now the same for side chains
9766 CV       do i=1,1
9767        do i=1,nres
9768         if (itype(i).eq.ntyp1) cycle
9769         positi=(mod(c(3,i+nres),boxzsize))
9770         if (positi.le.0) positi=positi+boxzsize
9771 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9772 c for each residue check if it is in lipid or lipid water border area
9773 C       respos=mod(c(3,i+nres),boxzsize)
9774 C       print *,positi,bordlipbot,buflipbot
9775        if ((positi.gt.bordlipbot)
9776      & .and.(positi.lt.bordliptop)) then
9777 C the energy transfer exist
9778         if (positi.lt.buflipbot) then
9779          fracinbuf=1.0d0-
9780      &     ((positi-bordlipbot)/lipbufthick)
9781 C lipbufthick is thickenes of lipid buffore
9782          sslip=sscalelip(fracinbuf)
9783          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9784          eliptran=eliptran+sslip*liptranene(itype(i))
9785          gliptranx(3,i)=gliptranx(3,i)
9786      &+ssgradlip*liptranene(itype(i))
9787          gliptranc(3,i-1)= gliptranc(3,i-1)
9788      &+ssgradlip*liptranene(itype(i))
9789 C         print *,"doing sccale for lower part"
9790         elseif (positi.gt.bufliptop) then
9791          fracinbuf=1.0d0-
9792      &((bordliptop-positi)/lipbufthick)
9793          sslip=sscalelip(fracinbuf)
9794          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9795          eliptran=eliptran+sslip*liptranene(itype(i))
9796          gliptranx(3,i)=gliptranx(3,i)
9797      &+ssgradlip*liptranene(itype(i))
9798          gliptranc(3,i-1)= gliptranc(3,i-1)
9799      &+ssgradlip*liptranene(itype(i))
9800 C          print *, "doing sscalefor top part",sslip,fracinbuf
9801         else
9802          eliptran=eliptran+liptranene(itype(i))
9803 C         print *,"I am in true lipid"
9804         endif
9805         endif ! if in lipid or buffor
9806 C       else
9807 C       eliptran=elpitran+0.0 ! I am in water
9808        enddo
9809        return
9810        end
9811
9812
9813 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9814
9815       SUBROUTINE MATVEC2(A1,V1,V2)
9816       implicit real*8 (a-h,o-z)
9817       include 'DIMENSIONS'
9818       DIMENSION A1(2,2),V1(2),V2(2)
9819 c      DO 1 I=1,2
9820 c        VI=0.0
9821 c        DO 3 K=1,2
9822 c    3     VI=VI+A1(I,K)*V1(K)
9823 c        Vaux(I)=VI
9824 c    1 CONTINUE
9825
9826       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9827       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9828
9829       v2(1)=vaux1
9830       v2(2)=vaux2
9831       END
9832 C---------------------------------------
9833       SUBROUTINE MATMAT2(A1,A2,A3)
9834       implicit real*8 (a-h,o-z)
9835       include 'DIMENSIONS'
9836       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9837 c      DIMENSION AI3(2,2)
9838 c        DO  J=1,2
9839 c          A3IJ=0.0
9840 c          DO K=1,2
9841 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9842 c          enddo
9843 c          A3(I,J)=A3IJ
9844 c       enddo
9845 c      enddo
9846
9847       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9848       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9849       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9850       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9851
9852       A3(1,1)=AI3_11
9853       A3(2,1)=AI3_21
9854       A3(1,2)=AI3_12
9855       A3(2,2)=AI3_22
9856       END
9857
9858 c-------------------------------------------------------------------------
9859       double precision function scalar2(u,v)
9860       implicit none
9861       double precision u(2),v(2)
9862       double precision sc
9863       integer i
9864       scalar2=u(1)*v(1)+u(2)*v(2)
9865       return
9866       end
9867
9868 C-----------------------------------------------------------------------------
9869
9870       subroutine transpose2(a,at)
9871       implicit none
9872       double precision a(2,2),at(2,2)
9873       at(1,1)=a(1,1)
9874       at(1,2)=a(2,1)
9875       at(2,1)=a(1,2)
9876       at(2,2)=a(2,2)
9877       return
9878       end
9879 c--------------------------------------------------------------------------
9880       subroutine transpose(n,a,at)
9881       implicit none
9882       integer n,i,j
9883       double precision a(n,n),at(n,n)
9884       do i=1,n
9885         do j=1,n
9886           at(j,i)=a(i,j)
9887         enddo
9888       enddo
9889       return
9890       end
9891 C---------------------------------------------------------------------------
9892       subroutine prodmat3(a1,a2,kk,transp,prod)
9893       implicit none
9894       integer i,j
9895       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9896       logical transp
9897 crc      double precision auxmat(2,2),prod_(2,2)
9898
9899       if (transp) then
9900 crc        call transpose2(kk(1,1),auxmat(1,1))
9901 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9902 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9903
9904            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9905      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9906            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9907      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9908            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9909      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9910            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9911      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9912
9913       else
9914 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9915 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9916
9917            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9918      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9919            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9920      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9921            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9922      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9923            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9924      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9925
9926       endif
9927 c      call transpose2(a2(1,1),a2t(1,1))
9928
9929 crc      print *,transp
9930 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9931 crc      print *,((prod(i,j),i=1,2),j=1,2)
9932
9933       return
9934       end
9935 C-----------------------------------------------------------------------------
9936       double precision function scalar(u,v)
9937       implicit none
9938       double precision u(3),v(3)
9939       double precision sc
9940       integer i
9941       sc=0.0d0
9942       do i=1,3
9943         sc=sc+u(i)*v(i)
9944       enddo
9945       scalar=sc
9946       return
9947       end
9948 C-----------------------------------------------------------------------
9949       double precision function sscale(r)
9950       double precision r,gamm
9951       include "COMMON.SPLITELE"
9952       if(r.lt.r_cut-rlamb) then
9953         sscale=1.0d0
9954       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9955         gamm=(r-(r_cut-rlamb))/rlamb
9956         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9957       else
9958         sscale=0d0
9959       endif
9960       return
9961       end
9962 C-----------------------------------------------------------------------
9963 C-----------------------------------------------------------------------
9964       double precision function sscagrad(r)
9965       double precision r,gamm
9966       include "COMMON.SPLITELE"
9967       if(r.lt.r_cut-rlamb) then
9968         sscagrad=0.0d0
9969       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9970         gamm=(r-(r_cut-rlamb))/rlamb
9971         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9972       else
9973         sscagrad=0.0d0
9974       endif
9975       return
9976       end
9977 C-----------------------------------------------------------------------
9978 C-----------------------------------------------------------------------
9979       double precision function sscalelip(r)
9980       double precision r,gamm
9981       include "COMMON.SPLITELE"
9982 C      if(r.lt.r_cut-rlamb) then
9983 C        sscale=1.0d0
9984 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9985 C        gamm=(r-(r_cut-rlamb))/rlamb
9986         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9987 C      else
9988 C        sscale=0d0
9989 C      endif
9990       return
9991       end
9992 C-----------------------------------------------------------------------
9993       double precision function sscagradlip(r)
9994       double precision r,gamm
9995       include "COMMON.SPLITELE"
9996 C     if(r.lt.r_cut-rlamb) then
9997 C        sscagrad=0.0d0
9998 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9999 C        gamm=(r-(r_cut-rlamb))/rlamb
10000         sscagradlip=r*(6*r-6.0d0)
10001 C      else
10002 C        sscagrad=0.0d0
10003 C      endif
10004       return
10005       end
10006
10007 C-----------------------------------------------------------------------
10008        subroutine set_shield_fac
10009       implicit real*8 (a-h,o-z)
10010       include 'DIMENSIONS'
10011       include 'DIMENSIONS.ZSCOPT'
10012       include 'COMMON.CHAIN'
10013       include 'COMMON.DERIV'
10014       include 'COMMON.IOUNITS'
10015       include 'COMMON.SHIELD'
10016       include 'COMMON.INTERACT'
10017 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10018       double precision div77_81/0.974996043d0/,
10019      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10020
10021 C the vector between center of side_chain and peptide group
10022        double precision pep_side(3),long,side_calf(3),
10023      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10024      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10025 C the line belowe needs to be changed for FGPROC>1
10026       do i=1,nres-1
10027       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10028       ishield_list(i)=0
10029 Cif there two consequtive dummy atoms there is no peptide group between them
10030 C the line below has to be changed for FGPROC>1
10031       VolumeTotal=0.0
10032       do k=1,nres
10033        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10034        dist_pep_side=0.0
10035        dist_side_calf=0.0
10036        do j=1,3
10037 C first lets set vector conecting the ithe side-chain with kth side-chain
10038       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10039 C      pep_side(j)=2.0d0
10040 C and vector conecting the side-chain with its proper calfa
10041       side_calf(j)=c(j,k+nres)-c(j,k)
10042 C      side_calf(j)=2.0d0
10043       pept_group(j)=c(j,i)-c(j,i+1)
10044 C lets have their lenght
10045       dist_pep_side=pep_side(j)**2+dist_pep_side
10046       dist_side_calf=dist_side_calf+side_calf(j)**2
10047       dist_pept_group=dist_pept_group+pept_group(j)**2
10048       enddo
10049        dist_pep_side=dsqrt(dist_pep_side)
10050        dist_pept_group=dsqrt(dist_pept_group)
10051        dist_side_calf=dsqrt(dist_side_calf)
10052       do j=1,3
10053         pep_side_norm(j)=pep_side(j)/dist_pep_side
10054         side_calf_norm(j)=dist_side_calf
10055       enddo
10056 C now sscale fraction
10057        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10058 C       print *,buff_shield,"buff"
10059 C now sscale
10060         if (sh_frac_dist.le.0.0) cycle
10061 C If we reach here it means that this side chain reaches the shielding sphere
10062 C Lets add him to the list for gradient
10063         ishield_list(i)=ishield_list(i)+1
10064 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10065 C this list is essential otherwise problem would be O3
10066         shield_list(ishield_list(i),i)=k
10067 C Lets have the sscale value
10068         if (sh_frac_dist.gt.1.0) then
10069          scale_fac_dist=1.0d0
10070          do j=1,3
10071          sh_frac_dist_grad(j)=0.0d0
10072          enddo
10073         else
10074          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10075      &                   *(2.0*sh_frac_dist-3.0d0)
10076          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10077      &                  /dist_pep_side/buff_shield*0.5
10078 C remember for the final gradient multiply sh_frac_dist_grad(j)
10079 C for side_chain by factor -2 !
10080          do j=1,3
10081          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10082 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10083 C     &                    sh_frac_dist_grad(j)
10084          enddo
10085         endif
10086 C        if ((i.eq.3).and.(k.eq.2)) then
10087 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10088 C     & ,"TU"
10089 C        endif
10090
10091 C this is what is now we have the distance scaling now volume...
10092       short=short_r_sidechain(itype(k))
10093       long=long_r_sidechain(itype(k))
10094       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10095 C now costhet_grad
10096 C       costhet=0.0d0
10097        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10098 C       costhet_fac=0.0d0
10099        do j=1,3
10100          costhet_grad(j)=costhet_fac*pep_side(j)
10101        enddo
10102 C remember for the final gradient multiply costhet_grad(j)
10103 C for side_chain by factor -2 !
10104 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10105 C pep_side0pept_group is vector multiplication
10106       pep_side0pept_group=0.0
10107       do j=1,3
10108       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10109       enddo
10110       cosalfa=(pep_side0pept_group/
10111      & (dist_pep_side*dist_side_calf))
10112       fac_alfa_sin=1.0-cosalfa**2
10113       fac_alfa_sin=dsqrt(fac_alfa_sin)
10114       rkprim=fac_alfa_sin*(long-short)+short
10115 C now costhet_grad
10116        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10117        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10118
10119        do j=1,3
10120          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10121      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10122      &*(long-short)/fac_alfa_sin*cosalfa/
10123      &((dist_pep_side*dist_side_calf))*
10124      &((side_calf(j))-cosalfa*
10125      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10126
10127         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10128      &*(long-short)/fac_alfa_sin*cosalfa
10129      &/((dist_pep_side*dist_side_calf))*
10130      &(pep_side(j)-
10131      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10132        enddo
10133
10134       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10135      &                    /VSolvSphere_div
10136      &                    *wshield
10137 C now the gradient...
10138 C grad_shield is gradient of Calfa for peptide groups
10139 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10140 C     &               costhet,cosphi
10141 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10142 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10143       do j=1,3
10144       grad_shield(j,i)=grad_shield(j,i)
10145 C gradient po skalowaniu
10146      &                +(sh_frac_dist_grad(j)
10147 C  gradient po costhet
10148      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10149      &-scale_fac_dist*(cosphi_grad_long(j))
10150      &/(1.0-cosphi) )*div77_81
10151      &*VofOverlap
10152 C grad_shield_side is Cbeta sidechain gradient
10153       grad_shield_side(j,ishield_list(i),i)=
10154      &        (sh_frac_dist_grad(j)*(-2.0d0)
10155      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10156      &       +scale_fac_dist*(cosphi_grad_long(j))
10157      &        *2.0d0/(1.0-cosphi))
10158      &        *div77_81*VofOverlap
10159
10160        grad_shield_loc(j,ishield_list(i),i)=
10161      &   scale_fac_dist*cosphi_grad_loc(j)
10162      &        *2.0d0/(1.0-cosphi)
10163      &        *div77_81*VofOverlap
10164       enddo
10165       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10166       enddo
10167       fac_shield(i)=VolumeTotal*div77_81+div4_81
10168 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10169       enddo
10170       return
10171       end
10172 C--------------------------------------------------------------------------
10173 C first for shielding is setting of function of side-chains
10174        subroutine set_shield_fac2
10175       implicit real*8 (a-h,o-z)
10176       include 'DIMENSIONS'
10177       include 'DIMENSIONS.ZSCOPT'
10178       include 'COMMON.CHAIN'
10179       include 'COMMON.DERIV'
10180       include 'COMMON.IOUNITS'
10181       include 'COMMON.SHIELD'
10182       include 'COMMON.INTERACT'
10183 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10184       double precision div77_81/0.974996043d0/,
10185      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10186
10187 C the vector between center of side_chain and peptide group
10188        double precision pep_side(3),long,side_calf(3),
10189      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10190      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10191 C the line belowe needs to be changed for FGPROC>1
10192       do i=1,nres-1
10193       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10194       ishield_list(i)=0
10195 Cif there two consequtive dummy atoms there is no peptide group between them
10196 C the line below has to be changed for FGPROC>1
10197       VolumeTotal=0.0
10198       do k=1,nres
10199        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10200        dist_pep_side=0.0
10201        dist_side_calf=0.0
10202        do j=1,3
10203 C first lets set vector conecting the ithe side-chain with kth side-chain
10204       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10205 C      pep_side(j)=2.0d0
10206 C and vector conecting the side-chain with its proper calfa
10207       side_calf(j)=c(j,k+nres)-c(j,k)
10208 C      side_calf(j)=2.0d0
10209       pept_group(j)=c(j,i)-c(j,i+1)
10210 C lets have their lenght
10211       dist_pep_side=pep_side(j)**2+dist_pep_side
10212       dist_side_calf=dist_side_calf+side_calf(j)**2
10213       dist_pept_group=dist_pept_group+pept_group(j)**2
10214       enddo
10215        dist_pep_side=dsqrt(dist_pep_side)
10216        dist_pept_group=dsqrt(dist_pept_group)
10217        dist_side_calf=dsqrt(dist_side_calf)
10218       do j=1,3
10219         pep_side_norm(j)=pep_side(j)/dist_pep_side
10220         side_calf_norm(j)=dist_side_calf
10221       enddo
10222 C now sscale fraction
10223        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10224 C       print *,buff_shield,"buff"
10225 C now sscale
10226         if (sh_frac_dist.le.0.0) cycle
10227 C If we reach here it means that this side chain reaches the shielding sphere
10228 C Lets add him to the list for gradient
10229         ishield_list(i)=ishield_list(i)+1
10230 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10231 C this list is essential otherwise problem would be O3
10232         shield_list(ishield_list(i),i)=k
10233 C Lets have the sscale value
10234         if (sh_frac_dist.gt.1.0) then
10235          scale_fac_dist=1.0d0
10236          do j=1,3
10237          sh_frac_dist_grad(j)=0.0d0
10238          enddo
10239         else
10240          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10241      &                   *(2.0d0*sh_frac_dist-3.0d0)
10242          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10243      &                  /dist_pep_side/buff_shield*0.5d0
10244 C remember for the final gradient multiply sh_frac_dist_grad(j)
10245 C for side_chain by factor -2 !
10246          do j=1,3
10247          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10248 C         sh_frac_dist_grad(j)=0.0d0
10249 C         scale_fac_dist=1.0d0
10250 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10251 C     &                    sh_frac_dist_grad(j)
10252          enddo
10253         endif
10254 C this is what is now we have the distance scaling now volume...
10255       short=short_r_sidechain(itype(k))
10256       long=long_r_sidechain(itype(k))
10257       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10258       sinthet=short/dist_pep_side*costhet
10259 C now costhet_grad
10260 C       costhet=0.6d0
10261 C       sinthet=0.8
10262        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10263 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10264 C     &             -short/dist_pep_side**2/costhet)
10265 C       costhet_fac=0.0d0
10266        do j=1,3
10267          costhet_grad(j)=costhet_fac*pep_side(j)
10268        enddo
10269 C remember for the final gradient multiply costhet_grad(j)
10270 C for side_chain by factor -2 !
10271 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10272 C pep_side0pept_group is vector multiplication
10273       pep_side0pept_group=0.0d0
10274       do j=1,3
10275       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10276       enddo
10277       cosalfa=(pep_side0pept_group/
10278      & (dist_pep_side*dist_side_calf))
10279       fac_alfa_sin=1.0d0-cosalfa**2
10280       fac_alfa_sin=dsqrt(fac_alfa_sin)
10281       rkprim=fac_alfa_sin*(long-short)+short
10282 C      rkprim=short
10283
10284 C now costhet_grad
10285        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10286 C       cosphi=0.6
10287        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10288        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10289      &      dist_pep_side**2)
10290 C       sinphi=0.8
10291        do j=1,3
10292          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10293      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10294      &*(long-short)/fac_alfa_sin*cosalfa/
10295      &((dist_pep_side*dist_side_calf))*
10296      &((side_calf(j))-cosalfa*
10297      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10298 C       cosphi_grad_long(j)=0.0d0
10299         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10300      &*(long-short)/fac_alfa_sin*cosalfa
10301      &/((dist_pep_side*dist_side_calf))*
10302      &(pep_side(j)-
10303      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10304 C       cosphi_grad_loc(j)=0.0d0
10305        enddo
10306 C      print *,sinphi,sinthet
10307       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10308      &                    /VSolvSphere_div
10309 C     &                    *wshield
10310 C now the gradient...
10311       do j=1,3
10312       grad_shield(j,i)=grad_shield(j,i)
10313 C gradient po skalowaniu
10314      &                +(sh_frac_dist_grad(j)*VofOverlap
10315 C  gradient po costhet
10316      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10317      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10318      &       sinphi/sinthet*costhet*costhet_grad(j)
10319      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10320      & )*wshield
10321 C grad_shield_side is Cbeta sidechain gradient
10322       grad_shield_side(j,ishield_list(i),i)=
10323      &        (sh_frac_dist_grad(j)*(-2.0d0)
10324      &        *VofOverlap
10325      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10326      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10327      &       sinphi/sinthet*costhet*costhet_grad(j)
10328      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10329      &       )*wshield
10330
10331        grad_shield_loc(j,ishield_list(i),i)=
10332      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10333      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10334      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10335      &        ))
10336      &        *wshield
10337       enddo
10338       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10339       enddo
10340       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10341 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10342 c     &  " wshield",wshield
10343 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10344       enddo
10345       return
10346       end
10347 C--------------------------------------------------------------------------
10348       double precision function tschebyshev(m,n,x,y)
10349       implicit none
10350       include "DIMENSIONS"
10351       integer i,m,n
10352       double precision x(n),y,yy(0:maxvar),aux
10353 c Tschebyshev polynomial. Note that the first term is omitted
10354 c m=0: the constant term is included
10355 c m=1: the constant term is not included
10356       yy(0)=1.0d0
10357       yy(1)=y
10358       do i=2,n
10359         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10360       enddo
10361       aux=0.0d0
10362       do i=m,n
10363         aux=aux+x(i)*yy(i)
10364       enddo
10365       tschebyshev=aux
10366       return
10367       end
10368 C--------------------------------------------------------------------------
10369       double precision function gradtschebyshev(m,n,x,y)
10370       implicit none
10371       include "DIMENSIONS"
10372       integer i,m,n
10373       double precision x(n+1),y,yy(0:maxvar),aux
10374 c Tschebyshev polynomial. Note that the first term is omitted
10375 c m=0: the constant term is included
10376 c m=1: the constant term is not included
10377       yy(0)=1.0d0
10378       yy(1)=2.0d0*y
10379       do i=2,n
10380         yy(i)=2*y*yy(i-1)-yy(i-2)
10381       enddo
10382       aux=0.0d0
10383       do i=m,n
10384         aux=aux+x(i+1)*yy(i)*(i+1)
10385 C        print *, x(i+1),yy(i),i
10386       enddo
10387       gradtschebyshev=aux
10388       return
10389       end
10390 c----------------------------------------------------------------------------
10391       double precision function sscale2(r,r_cut,r0,rlamb)
10392       implicit none
10393       double precision r,gamm,r_cut,r0,rlamb,rr
10394       rr = dabs(r-r0)
10395 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10396 c      write (2,*) "rr",rr
10397       if(rr.lt.r_cut-rlamb) then
10398         sscale2=1.0d0
10399       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10400         gamm=(rr-(r_cut-rlamb))/rlamb
10401         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10402       else
10403         sscale2=0d0
10404       endif
10405       return
10406       end
10407 C-----------------------------------------------------------------------
10408       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10409       implicit none
10410       double precision r,gamm,r_cut,r0,rlamb,rr
10411       rr = dabs(r-r0)
10412       if(rr.lt.r_cut-rlamb) then
10413         sscalgrad2=0.0d0
10414       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10415         gamm=(rr-(r_cut-rlamb))/rlamb
10416         if (r.ge.r0) then
10417           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10418         else
10419           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10420         endif
10421       else
10422         sscalgrad2=0.0d0
10423       endif
10424       return
10425       end
10426 c----------------------------------------------------------------------------
10427       subroutine e_saxs(Esaxs_constr)
10428       implicit none
10429       include 'DIMENSIONS'
10430       include 'DIMENSIONS.ZSCOPT'
10431       include 'DIMENSIONS.FREE'
10432 #ifdef MPI
10433       include "mpif.h"
10434       include "COMMON.SETUP"
10435       integer IERR
10436 #endif
10437       include 'COMMON.SBRIDGE'
10438       include 'COMMON.CHAIN'
10439       include 'COMMON.GEO'
10440       include 'COMMON.LOCAL'
10441       include 'COMMON.INTERACT'
10442       include 'COMMON.VAR'
10443       include 'COMMON.IOUNITS'
10444       include 'COMMON.DERIV'
10445       include 'COMMON.CONTROL'
10446       include 'COMMON.NAMES'
10447       include 'COMMON.FFIELD'
10448       include 'COMMON.LANGEVIN'
10449       include 'COMMON.SAXS'
10450 c
10451       double precision Esaxs_constr
10452       integer i,iint,j,k,l
10453       double precision PgradC(maxSAXS,3,maxres),
10454      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10455 #ifdef MPI
10456       double precision PgradC_(maxSAXS,3,maxres),
10457      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10458 #endif
10459       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10460      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10461      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10462      & auxX,auxX1,CACAgrad,Cnorm
10463       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10464       double precision dist
10465       external dist
10466 c  SAXS restraint penalty function
10467 #ifdef DEBUG
10468       write(iout,*) "------- SAXS penalty function start -------"
10469       write (iout,*) "nsaxs",nsaxs
10470       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10471       write (iout,*) "Psaxs"
10472       do i=1,nsaxs
10473         write (iout,'(i5,e15.5)') i, Psaxs(i)
10474       enddo
10475 #endif
10476       Esaxs_constr = 0.0d0
10477       do k=1,nsaxs
10478         Pcalc(k)=0.0d0
10479         do j=1,nres
10480           do l=1,3
10481             PgradC(k,l,j)=0.0d0
10482             PgradX(k,l,j)=0.0d0
10483           enddo
10484         enddo
10485       enddo
10486       do i=iatsc_s,iatsc_e
10487        if (itype(i).eq.ntyp1) cycle
10488        do iint=1,nint_gr(i)
10489          do j=istart(i,iint),iend(i,iint)
10490            if (itype(j).eq.ntyp1) cycle
10491 #ifdef ALLSAXS
10492            dijCACA=dist(i,j)
10493            dijCASC=dist(i,j+nres)
10494            dijSCCA=dist(i+nres,j)
10495            dijSCSC=dist(i+nres,j+nres)
10496            sigma2CACA=2.0d0/(pstok**2)
10497            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10498            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10499            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10500            do k=1,nsaxs
10501              dk = distsaxs(k)
10502              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10503              if (itype(j).ne.10) then
10504              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10505              else
10506              endif
10507              expCASC = 0.0d0
10508              if (itype(i).ne.10) then
10509              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10510              else
10511              expSCCA = 0.0d0
10512              endif
10513              if (itype(i).ne.10 .and. itype(j).ne.10) then
10514              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10515              else
10516              expSCSC = 0.0d0
10517              endif
10518              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10519 #ifdef DEBUG
10520              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10521 #endif
10522              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10523              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10524              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10525              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10526              do l=1,3
10527 c CA CA
10528                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10529                PgradC(k,l,i) = PgradC(k,l,i)-aux
10530                PgradC(k,l,j) = PgradC(k,l,j)+aux
10531 c CA SC
10532                if (itype(j).ne.10) then
10533                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10534                PgradC(k,l,i) = PgradC(k,l,i)-aux
10535                PgradC(k,l,j) = PgradC(k,l,j)+aux
10536                PgradX(k,l,j) = PgradX(k,l,j)+aux
10537                endif
10538 c SC CA
10539                if (itype(i).ne.10) then
10540                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10541                PgradX(k,l,i) = PgradX(k,l,i)-aux
10542                PgradC(k,l,i) = PgradC(k,l,i)-aux
10543                PgradC(k,l,j) = PgradC(k,l,j)+aux
10544                endif
10545 c SC SC
10546                if (itype(i).ne.10 .and. itype(j).ne.10) then
10547                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10548                PgradC(k,l,i) = PgradC(k,l,i)-aux
10549                PgradC(k,l,j) = PgradC(k,l,j)+aux
10550                PgradX(k,l,i) = PgradX(k,l,i)-aux
10551                PgradX(k,l,j) = PgradX(k,l,j)+aux
10552                endif
10553              enddo ! l
10554            enddo ! k
10555 #else
10556            dijCACA=dist(i,j)
10557            sigma2CACA=scal_rad**2*0.25d0/
10558      &        (restok(itype(j))**2+restok(itype(i))**2)
10559
10560            IF (saxs_cutoff.eq.0) THEN
10561            do k=1,nsaxs
10562              dk = distsaxs(k)
10563              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10564              Pcalc(k) = Pcalc(k)+expCACA
10565              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10566              do l=1,3
10567                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10568                PgradC(k,l,i) = PgradC(k,l,i)-aux
10569                PgradC(k,l,j) = PgradC(k,l,j)+aux
10570              enddo ! l
10571            enddo ! k
10572            ELSE
10573            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10574            do k=1,nsaxs
10575              dk = distsaxs(k)
10576 c             write (2,*) "ijk",i,j,k
10577              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10578              if (sss2.eq.0.0d0) cycle
10579              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10580              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10581              Pcalc(k) = Pcalc(k)+expCACA
10582 #ifdef DEBUG
10583              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10584 #endif
10585              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10586      &             ssgrad2*expCACA/sss2
10587              do l=1,3
10588 c CA CA
10589                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10590                PgradC(k,l,i) = PgradC(k,l,i)+aux
10591                PgradC(k,l,j) = PgradC(k,l,j)-aux
10592              enddo ! l
10593            enddo ! k
10594            ENDIF
10595 #endif
10596          enddo ! j
10597        enddo ! iint
10598       enddo ! i
10599 #ifdef MPI
10600       if (nfgtasks.gt.1) then
10601         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10602      &    MPI_SUM,king,FG_COMM,IERR)
10603         if (fg_rank.eq.king) then
10604           do k=1,nsaxs
10605             Pcalc(k) = Pcalc_(k)
10606           enddo
10607         endif
10608         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10609      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10610         if (fg_rank.eq.king) then
10611           do i=1,nres
10612             do l=1,3
10613               do k=1,nsaxs
10614                 PgradC(k,l,i) = PgradC_(k,l,i)
10615               enddo
10616             enddo
10617           enddo
10618         endif
10619 #ifdef ALLSAXS
10620         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10621      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10622         if (fg_rank.eq.king) then
10623           do i=1,nres
10624             do l=1,3
10625               do k=1,nsaxs
10626                 PgradX(k,l,i) = PgradX_(k,l,i)
10627               enddo
10628             enddo
10629           enddo
10630         endif
10631 #endif
10632       endif
10633 #endif
10634 #ifdef MPI
10635       if (fg_rank.eq.king) then
10636 #endif
10637       Cnorm = 0.0d0
10638       do k=1,nsaxs
10639         Cnorm = Cnorm + Pcalc(k)
10640       enddo
10641       Esaxs_constr = dlog(Cnorm)-wsaxs0
10642       do k=1,nsaxs
10643         if (Pcalc(k).gt.0.0d0)
10644      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10645 #ifdef DEBUG
10646         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10647 #endif
10648       enddo
10649 #ifdef DEBUG
10650       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10651 #endif
10652       do i=nnt,nct
10653         do l=1,3
10654           auxC=0.0d0
10655           auxC1=0.0d0
10656           auxX=0.0d0
10657           auxX1=0.d0
10658           do k=1,nsaxs
10659             if (Pcalc(k).gt.0)
10660      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10661             auxC1 = auxC1+PgradC(k,l,i)
10662 #ifdef ALLSAXS
10663             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10664             auxX1 = auxX1+PgradX(k,l,i)
10665 #endif
10666           enddo
10667           gsaxsC(l,i) = auxC - auxC1/Cnorm
10668 #ifdef ALLSAXS
10669           gsaxsX(l,i) = auxX - auxX1/Cnorm
10670 #endif
10671 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10672 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10673         enddo
10674       enddo
10675 #ifdef MPI
10676       endif
10677 #endif
10678       return
10679       end
10680 c----------------------------------------------------------------------------
10681       subroutine e_saxsC(Esaxs_constr)
10682       implicit none
10683       include 'DIMENSIONS'
10684       include 'DIMENSIONS.ZSCOPT'
10685       include 'DIMENSIONS.FREE'
10686 #ifdef MPI
10687       include "mpif.h"
10688       include "COMMON.SETUP"
10689       integer IERR
10690 #endif
10691       include 'COMMON.SBRIDGE'
10692       include 'COMMON.CHAIN'
10693       include 'COMMON.GEO'
10694       include 'COMMON.LOCAL'
10695       include 'COMMON.INTERACT'
10696       include 'COMMON.VAR'
10697       include 'COMMON.IOUNITS'
10698       include 'COMMON.DERIV'
10699       include 'COMMON.CONTROL'
10700       include 'COMMON.NAMES'
10701       include 'COMMON.FFIELD'
10702       include 'COMMON.LANGEVIN'
10703       include 'COMMON.SAXS'
10704 c
10705       double precision Esaxs_constr
10706       integer i,iint,j,k,l
10707       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10708 #ifdef MPI
10709       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10710 #endif
10711       double precision dk,dijCASPH,dijSCSPH,
10712      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10713      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10714      & auxX,auxX1,Cnorm
10715 c  SAXS restraint penalty function
10716 #ifdef DEBUG
10717       write(iout,*) "------- SAXS penalty function start -------"
10718       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10719      & " isaxs_end",isaxs_end
10720       write (iout,*) "nnt",nnt," ntc",nct
10721       do i=nnt,nct
10722         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10723      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10724       enddo
10725       do i=nnt,nct
10726         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10727       enddo
10728 #endif
10729       Esaxs_constr = 0.0d0
10730       logPtot=0.0d0
10731       do j=isaxs_start,isaxs_end
10732         Pcalc=0.0d0
10733         do i=1,nres
10734           do l=1,3
10735             PgradC(l,i)=0.0d0
10736             PgradX(l,i)=0.0d0
10737           enddo
10738         enddo
10739         do i=nnt,nct
10740           dijCASPH=0.0d0
10741           dijSCSPH=0.0d0
10742           do l=1,3
10743             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10744           enddo
10745           if (itype(i).ne.10) then
10746           do l=1,3
10747             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10748           enddo
10749           endif
10750           sigma2CA=2.0d0/pstok**2
10751           sigma2SC=4.0d0/restok(itype(i))**2
10752           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10753           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10754           Pcalc = Pcalc+expCASPH+expSCSPH
10755 #ifdef DEBUG
10756           write(*,*) "processor i j Pcalc",
10757      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10758 #endif
10759           CASPHgrad = sigma2CA*expCASPH
10760           SCSPHgrad = sigma2SC*expSCSPH
10761           do l=1,3
10762             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10763             PgradX(l,i) = PgradX(l,i) + aux
10764             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10765           enddo ! l
10766         enddo ! i
10767         do i=nnt,nct
10768           do l=1,3
10769             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10770             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10771           enddo
10772         enddo
10773         logPtot = logPtot - dlog(Pcalc)
10774 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10775 c     &    " logPtot",logPtot
10776       enddo ! j
10777 #ifdef MPI
10778       if (nfgtasks.gt.1) then
10779 c        write (iout,*) "logPtot before reduction",logPtot
10780         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10781      &    MPI_SUM,king,FG_COMM,IERR)
10782         logPtot = logPtot_
10783 c        write (iout,*) "logPtot after reduction",logPtot
10784         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10785      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10786         if (fg_rank.eq.king) then
10787           do i=1,nres
10788             do l=1,3
10789               gsaxsC(l,i) = gsaxsC_(l,i)
10790             enddo
10791           enddo
10792         endif
10793         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10794      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10795         if (fg_rank.eq.king) then
10796           do i=1,nres
10797             do l=1,3
10798               gsaxsX(l,i) = gsaxsX_(l,i)
10799             enddo
10800           enddo
10801         endif
10802       endif
10803 #endif
10804       Esaxs_constr = logPtot
10805       return
10806       end
10807