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 eello_turn4',eello_turn4
  60
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68
  69       call ebond(estr)
  70 C       write (iout,*) "estr",estr
  71 C
  72 C Calculate the disulfide-bridge and other energy and the contributions
  73 C from other distance constraints.
  74 cd    print *,'Calling EHPB'
  75       call edis(ehpb)
  76 cd    print *,'EHPB exitted succesfully.'
  77 C
  78 C Calculate the virtual-bond-angle energy.
  79 C
  80 C      print *,'Bend energy finished.'
  81       if (wang.gt.0d0) then
  82        if (tor_mode.eq.0) then
  83          call ebend(ebe)
  84        else
  85 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  86 C energy function
  87          call ebend_kcc(ebe)
  88        endif
  89       else
  90         ebe=0.0d0
  91       endif
  92       ethetacnstr=0.0d0
  93       if (with_theta_constr) call etheta_constr(ethetacnstr)
  94 c      call ebend(ebe,ethetacnstr)
  95 cd    print *,'Bend energy finished.'
  96 C
  97 C Calculate the SC local energy.
  98 C
  99       call esc(escloc)
 100 C       print *,'SCLOC energy finished.'
 101 C
 102 C Calculate the virtual-bond torsional energy.
 103 C
 104       if (wtor.gt.0.0d0) then
 105          if (tor_mode.eq.0) then
 106            call etor(etors,fact(1))
 107          else
 108 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 109 C energy function
 110            call etor_kcc(etors,fact(1))
 111          endif
 112       else
 113         etors=0.0d0
 114       endif
 115       edihcnstr=0.0d0
 116       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 117 c      print *,"Processor",myrank," computed Utor"
 118 C
 119 C 6/23/01 Calculate double-torsional energy
 120 C
 121       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 122         call etor_d(etors_d,fact(2))
 123       else
 124         etors_d=0
 125       endif
 126 c      print *,"Processor",myrank," computed Utord"
 127 C
 128       if (wsccor.gt.0.0d0) then
 129         call eback_sc_corr(esccor)
 130       else
 131         esccor=0.0d0
 132       endif
 133
 134       if (wliptran.gt.0) then
 135         call Eliptransfer(eliptran)
 136       else
 137         eliptran=0.0d0
 138       endif
 139 #ifdef FOURBODY
 140 C
 141 C 12/1/95 Multi-body terms
 142 C
 143       n_corr=0
 144       n_corr1=0
 145       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 146      &    .or. wturn6.gt.0.0d0) then
 147 c         write(iout,*)"calling multibody_eello"
 148          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 149 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 150 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 151       else
 152          ecorr=0.0d0
 153          ecorr5=0.0d0
 154          ecorr6=0.0d0
 155          eturn6=0.0d0
 156       endif
 157       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 158 c         write (iout,*) "Calling multibody_hbond"
 159          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 160       endif
 161 #endif
 162 c      write (iout,*) "nsaxs",nsaxs
 163 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 164       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 165         call e_saxs(Esaxs_constr)
 166 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 167       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 168         call e_saxsC(Esaxs_constr)
 169 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 170       else
 171         Esaxs_constr = 0.0d0
 172       endif
 173
 174 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 175       if (constr_homology.ge.1) then
 176         call e_modeller(ehomology_constr)
 177       else
 178         ehomology_constr=0.0d0
 179       endif
 180
 181 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 182 #ifdef DFA
 183 C     BARTEK for dfa test!
 184       edfadis=0.0d0
 185       if (wdfa_dist.gt.0) call edfad(edfadis)
 186 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 187       edfator=0.0d0
 188       if (wdfa_tor.gt.0) call edfat(edfator)
 189 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 190       edfanei=0.0d0
 191       if (wdfa_nei.gt.0) call edfan(edfanei)
 192 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 193       edfabet=0.0d0
 194       if (wdfa_beta.gt.0) call edfab(edfabet)
 195 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 196 #else
 197       edfadis=0.0d0
 198       edfator=0.0d0
 199       edfanei=0.0d0
 200       edfabet=0.0d0
 201 #endif
 202 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 203 #ifdef SPLITELE
 204       if (shield_mode.gt.0) then
 205       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 206      & +welec*fact(1)*ees
 207      & +fact(1)*wvdwpp*evdw1
 208      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 209      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 210      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 211      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 212      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 213      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 214      & +wliptran*eliptran*esaxs_constr
 215      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 216      & +wdfa_beta*edfabet
 217       else
 218       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 219      & +wvdwpp*evdw1
 220      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 221      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 222      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 223      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 224      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 225      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 226      & +wliptran*eliptran+wsaxs*esaxs_constr
 227      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 228      & +wdfa_beta*edfabet
 229       endif
 230 #else
 231       if (shield_mode.gt.0) then
 232       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 233      & +welec*fact(1)*(ees+evdw1)
 234      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 235      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 236      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 237      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 238      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 239      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 240      & +wliptran*eliptran+wsaxs*esaxs_constr
 241      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 242      & +wdfa_beta*edfabet
 243       else
 244       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 245      & +welec*fact(1)*(ees+evdw1)
 246      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 247      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 248      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 249      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 250      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 251      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 252      & +wliptran*eliptran+wsaxs*esaxs_constr
 253      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 254      & +wdfa_beta*edfabet
 255       endif
 256 #endif
 257       energia(0)=etot
 258       energia(1)=evdw
 259 #ifdef SCP14
 260       energia(2)=evdw2-evdw2_14
 261       energia(17)=evdw2_14
 262 #else
 263       energia(2)=evdw2
 264       energia(17)=0.0d0
 265 #endif
 266 #ifdef SPLITELE
 267       energia(3)=ees
 268       energia(16)=evdw1
 269 #else
 270       energia(3)=ees+evdw1
 271       energia(16)=0.0d0
 272 #endif
 273       energia(4)=ecorr
 274       energia(5)=ecorr5
 275       energia(6)=ecorr6
 276       energia(7)=eel_loc
 277       energia(8)=eello_turn3
 278       energia(9)=eello_turn4
 279       energia(10)=eturn6
 280       energia(11)=ebe
 281       energia(12)=escloc
 282       energia(13)=etors
 283       energia(14)=etors_d
 284       energia(15)=ehpb
 285       energia(18)=estr
 286       energia(19)=esccor
 287       energia(20)=edihcnstr
 288       energia(21)=evdw_t
 289       energia(22)=eliptran
 290       energia(24)=ethetacnstr
 291       energia(26)=esaxs_constr
 292       energia(27)=ehomology_constr
 293       energia(28)=edfadis
 294       energia(29)=edfator
 295       energia(30)=edfanei
 296       energia(31)=edfabet
 297 c detecting NaNQ
 298 #ifdef ISNAN
 299 #ifdef AIX
 300       if (isnan(etot).ne.0) energia(0)=1.0d+99
 301 #else
 302       if (isnan(etot)) energia(0)=1.0d+99
 303 #endif
 304 #else
 305       i=0
 306 #ifdef WINPGI
 307       idumm=proc_proc(etot,i)
 308 #else
 309       call proc_proc(etot,i)
 310 #endif
 311       if(i.eq.1)energia(0)=1.0d+99
 312 #endif
 313 #ifdef MPL
 314 c     endif
 315 #endif
 316 #ifdef DEBUG
 317       call enerprint(energia,fact)
 318 #endif
 319       if (calc_grad) then
 320 C
 321 C Sum up the components of the Cartesian gradient.
 322 C
 323 #ifdef SPLITELE
 324       do i=1,nct
 325         do j=1,3
 326       if (shield_mode.eq.0) then
 327           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 328      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 329      &                wbond*gradb(j,i)+
 330      &                wstrain*ghpbc(j,i)+
 331      &                wcorr*fact(3)*gradcorr(j,i)+
 332      &                wel_loc*fact(2)*gel_loc(j,i)+
 333      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 334      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 335      &                wcorr5*fact(4)*gradcorr5(j,i)+
 336      &                wcorr6*fact(5)*gradcorr6(j,i)+
 337      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 338      &                wsccor*fact(2)*gsccorc(j,i)+
 339      &                wliptran*gliptranc(j,i)+
 340      &                wdfa_dist*gdfad(j,i)+
 341      &                wdfa_tor*gdfat(j,i)+
 342      &                wdfa_nei*gdfan(j,i)+
 343      &                wdfa_beta*gdfab(j,i)
 344           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 345      &                  wbond*gradbx(j,i)+
 346      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 347      &                  wsccor*fact(2)*gsccorx(j,i)
 348      &                 +wliptran*gliptranx(j,i)
 349         else
 350           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 351      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 352      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 353      &                wbond*gradb(j,i)+
 354      &                wstrain*ghpbc(j,i)+
 355      &                wcorr*fact(3)*gradcorr(j,i)+
 356      &                wel_loc*fact(2)*gel_loc(j,i)+
 357      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 358      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 359      &                wcorr5*fact(4)*gradcorr5(j,i)+
 360      &                wcorr6*fact(5)*gradcorr6(j,i)+
 361      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 362      &                wsccor*fact(2)*gsccorc(j,i)
 363      &               +wliptran*gliptranc(j,i)
 364      &                 +welec*gshieldc(j,i)
 365      &                 +welec*gshieldc_loc(j,i)
 366      &                 +wcorr*gshieldc_ec(j,i)
 367      &                 +wcorr*gshieldc_loc_ec(j,i)
 368      &                 +wturn3*gshieldc_t3(j,i)
 369      &                 +wturn3*gshieldc_loc_t3(j,i)
 370      &                 +wturn4*gshieldc_t4(j,i)
 371      &                 +wturn4*gshieldc_loc_t4(j,i)
 372      &                 +wel_loc*gshieldc_ll(j,i)
 373      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 374      &                wdfa_dist*gdfad(j,i)+
 375      &                wdfa_tor*gdfat(j,i)+
 376      &                wdfa_nei*gdfan(j,i)+
 377      &                wdfa_beta*gdfab(j,i)
 378           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 379      &                 +fact(1)*wscp*gradx_scp(j,i)+
 380      &                  wbond*gradbx(j,i)+
 381      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 382      &                  wsccor*fact(2)*gsccorx(j,i)
 383      &                 +wliptran*gliptranx(j,i)
 384      &                 +welec*gshieldx(j,i)
 385      &                 +wcorr*gshieldx_ec(j,i)
 386      &                 +wturn3*gshieldx_t3(j,i)
 387      &                 +wturn4*gshieldx_t4(j,i)
 388      &                 +wel_loc*gshieldx_ll(j,i)
 389         endif
 390         enddo
 391 #else
 392       do i=1,nct
 393         do j=1,3
 394                 if (shield_mode.eq.0) then
 395           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 396      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 397      &                wbond*gradb(j,i)+
 398      &                wcorr*fact(3)*gradcorr(j,i)+
 399      &                wel_loc*fact(2)*gel_loc(j,i)+
 400      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 401      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 402      &                wcorr5*fact(4)*gradcorr5(j,i)+
 403      &                wcorr6*fact(5)*gradcorr6(j,i)+
 404      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 405      &                wsccor*fact(2)*gsccorc(j,i)
 406      &               +wliptran*gliptranc(j,i)+
 407      &                wdfa_dist*gdfad(j,i)+
 408      &                wdfa_tor*gdfat(j,i)+
 409      &                wdfa_nei*gdfan(j,i)+
 410      &                wdfa_beta*gdfab(j,i)
 411
 412           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 413      &                  wbond*gradbx(j,i)+
 414      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 415      &                  wsccor*fact(1)*gsccorx(j,i)
 416      &                 +wliptran*gliptranx(j,i)
 417               else
 418           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 419      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 420      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 421      &                wbond*gradb(j,i)+
 422      &                wcorr*fact(3)*gradcorr(j,i)+
 423      &                wel_loc*fact(2)*gel_loc(j,i)+
 424      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 425      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 426      &                wcorr5*fact(4)*gradcorr5(j,i)+
 427      &                wcorr6*fact(5)*gradcorr6(j,i)+
 428      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 429      &                wsccor*fact(2)*gsccorc(j,i)
 430      &               +wliptran*gliptranc(j,i)
 431      &                 +welec*gshieldc(j,i)
 432      &                 +welec*gshieldc_loc(j,i)
 433      &                 +wcorr*gshieldc_ec(j,i)
 434      &                 +wcorr*gshieldc_loc_ec(j,i)
 435      &                 +wturn3*gshieldc_t3(j,i)
 436      &                 +wturn3*gshieldc_loc_t3(j,i)
 437      &                 +wturn4*gshieldc_t4(j,i)
 438      &                 +wturn4*gshieldc_loc_t4(j,i)
 439      &                 +wel_loc*gshieldc_ll(j,i)
 440      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 441      &                wdfa_dist*gdfad(j,i)+
 442      &                wdfa_tor*gdfat(j,i)+
 443      &                wdfa_nei*gdfan(j,i)+
 444      &                wdfa_beta*gdfab(j,i)
 445           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 446      &                  fact(1)*wscp*gradx_scp(j,i)+
 447      &                  wbond*gradbx(j,i)+
 448      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 449      &                  wsccor*fact(1)*gsccorx(j,i)
 450      &                 +wliptran*gliptranx(j,i)
 451      &                 +welec*gshieldx(j,i)
 452      &                 +wcorr*gshieldx_ec(j,i)
 453      &                 +wturn3*gshieldx_t3(j,i)
 454      &                 +wturn4*gshieldx_t4(j,i)
 455      &                 +wel_loc*gshieldx_ll(j,i)
 456
 457          endif
 458         enddo
 459 #endif
 460       enddo
 461
 462
 463       do i=1,nres-3
 464         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 465      &   +wcorr5*fact(4)*g_corr5_loc(i)
 466      &   +wcorr6*fact(5)*g_corr6_loc(i)
 467      &   +wturn4*fact(3)*gel_loc_turn4(i)
 468      &   +wturn3*fact(2)*gel_loc_turn3(i)
 469      &   +wturn6*fact(5)*gel_loc_turn6(i)
 470      &   +wel_loc*fact(2)*gel_loc_loc(i)
 471 c     &   +wsccor*fact(1)*gsccor_loc(i)
 472 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 473       enddo
 474       endif
 475       if (dyn_ss) call dyn_set_nss
 476       return
 477       end
 478 C------------------------------------------------------------------------
 479       subroutine enerprint(energia,fact)
 480       implicit real*8 (a-h,o-z)
 481       include 'DIMENSIONS'
 482       include 'DIMENSIONS.ZSCOPT'
 483       include 'COMMON.IOUNITS'
 484       include 'COMMON.FFIELD'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CONTROL'
 487       double precision energia(0:max_ene),fact(6)
 488       etot=energia(0)
 489       evdw=energia(1)+fact(6)*energia(21)
 490 #ifdef SCP14
 491       evdw2=energia(2)+energia(17)
 492 #else
 493       evdw2=energia(2)
 494 #endif
 495       ees=energia(3)
 496 #ifdef SPLITELE
 497       evdw1=energia(16)
 498 #endif
 499       ecorr=energia(4)
 500       ecorr5=energia(5)
 501       ecorr6=energia(6)
 502       eel_loc=energia(7)
 503       eello_turn3=energia(8)
 504       eello_turn4=energia(9)
 505       eello_turn6=energia(10)
 506       ebe=energia(11)
 507       escloc=energia(12)
 508       etors=energia(13)
 509       etors_d=energia(14)
 510       ehpb=energia(15)
 511       esccor=energia(19)
 512       edihcnstr=energia(20)
 513       estr=energia(18)
 514       ethetacnstr=energia(24)
 515       eliptran=energia(22)
 516       esaxs=energia(26)
 517       ehomology_constr=energia(27)
 518 C     Bartek
 519       edfadis = energia(28)
 520       edfator = energia(29)
 521       edfanei = energia(30)
 522       edfabet = energia(31)
 523       Eafmforc=0.0d0
 524       etube=0.0d0
 525       Uconst=0.0d0
 526 #ifdef SPLITELE
 527       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 528      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 529      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 530 #ifdef FOURBODY
 531      &  ecorr,wcorr*fact(3),
 532      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 533 #endif
 534      &  eel_loc,
 535      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 536      &  eello_turn4,wturn4*fact(3),
 537 #ifdef FOURBODY
 538      &  eello_turn6,wturn6*fact(5),
 539 #endif
 540      &  esccor,wsccor*fact(1),edihcnstr,
 541      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 542      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 543      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 544      &  edfabet,wdfa_beta,
 545      &  etot
 546    10 format (/'Virtual-chain energies:'//
 547      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 548      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 549      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 550      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 551      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 552      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 553      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 554      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 555      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 556      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 557      & ' (SS bridges & dist. cnstr.)'/
 558 #ifdef FOURBODY
 559      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 560      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 561      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 562 #endif
 563      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 564      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 565      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 566 #ifdef FOURBODY
 567      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 568 #endif
 569      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 570      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 571      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 572      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 573      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 574      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 575      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 576      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 577      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 578      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 579      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 580      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 581      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 582      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 583      & 'ETOT=  ',1pE16.6,' (total)')
 584
 585 #else
 586       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 587      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 588      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 589 #ifdef FOURBODY
 590      &  ecorr,wcorr*fact(3),
 591      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 592 #endif
 593      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 594      &  eello_turn4,wturn4*fact(3),
 595 #ifdef FOURBODY
 596      &  eello_turn6,wturn6*fact(5),
 597 #endif
 598      &  esccor,wsccor*fact(1),edihcnstr,
 599      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 600      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 601      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 602      &  edfabet,wdfa_beta,
 603      &  etot
 604    10 format (/'Virtual-chain energies:'//
 605      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 606      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 607      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 608      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 609      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 610      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 611      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 612      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 613      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 614      & ' (SS bridges & dist. restr.)'/
 615 #ifdef FOURBODY
 616      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 617      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 618      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 619 #endif
 620      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 621      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 622      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 623 #ifdef FOURBODY
 624      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 625 #endif
 626      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 627      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 628      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 629      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 630      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 631      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 632      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 633      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 634      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 635      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 636      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 637      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 638      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 639      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 640      & 'ETOT=  ',1pE16.6,' (total)')
 641 #endif
 642       return
 643       end
 644 C-----------------------------------------------------------------------
 645       subroutine elj(evdw,evdw_t)
 646 C
 647 C This subroutine calculates the interaction energy of nonbonded side chains
 648 C assuming the LJ potential of interaction.
 649 C
 650       implicit real*8 (a-h,o-z)
 651       include 'DIMENSIONS'
 652       include 'DIMENSIONS.ZSCOPT'
 653       include "DIMENSIONS.COMPAR"
 654       parameter (accur=1.0d-10)
 655       include 'COMMON.GEO'
 656       include 'COMMON.VAR'
 657       include 'COMMON.LOCAL'
 658       include 'COMMON.CHAIN'
 659       include 'COMMON.DERIV'
 660       include 'COMMON.INTERACT'
 661       include 'COMMON.TORSION'
 662       include 'COMMON.ENEPS'
 663       include 'COMMON.SBRIDGE'
 664       include 'COMMON.NAMES'
 665       include 'COMMON.IOUNITS'
 666 #ifdef FOURBODY
 667       include 'COMMON.CONTACTS'
 668       include 'COMMON.CONTMAT'
 669 #endif
 670       dimension gg(3)
 671       integer icant
 672       external icant
 673 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 674 c ROZNICA z cluster
 675       do i=1,210
 676         do j=1,2
 677           eneps_temp(j,i)=0.0d0
 678         enddo
 679       enddo
 680 cROZNICA
 681
 682       evdw=0.0D0
 683       evdw_t=0.0d0
 684       do i=iatsc_s,iatsc_e
 685         itypi=iabs(itype(i))
 686         if (itypi.eq.ntyp1) cycle
 687         itypi1=iabs(itype(i+1))
 688         xi=c(1,nres+i)
 689         yi=c(2,nres+i)
 690         zi=c(3,nres+i)
 691         call to_box(xi,yi,zi)
 692 C Change 12/1/95
 693         num_conti=0
 694 C
 695 C Calculate SC interaction energy.
 696 C
 697         do iint=1,nint_gr(i)
 698 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 699 cd   &                  'iend=',iend(i,iint)
 700           do j=istart(i,iint),iend(i,iint)
 701             itypj=iabs(itype(j))
 702             if (itypj.eq.ntyp1) cycle
 703             xj=c(1,nres+j)-xi
 704             yj=c(2,nres+j)-yi
 705             zj=c(3,nres+j)-zi
 706             call to_box(xj,yj,zj)
 707             xj=boxshift(xj-xi,boxxsize)
 708             yj=boxshift(yj-yi,boxysize)
 709             zj=boxshift(zj-zi,boxzsize)
 710 C Change 12/1/95 to calculate four-body interactions
 711             rij=xj*xj+yj*yj+zj*zj
 712             rrij=1.0D0/rij
 713             sqrij=dsqrt(rij)
 714             sss1=sscale(sqrij)
 715             if (sss1.eq.0.0d0) cycle
 716             sssgrad1=sscagrad(sqrij)
 717 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 718             eps0ij=eps(itypi,itypj)
 719             fac=rrij**expon2
 720             e1=fac*fac*aa
 721             e2=fac*bb
 722             evdwij=e1+e2
 723             ij=icant(itypi,itypj)
 724 c ROZNICA z cluster
 725             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 726             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 727 c
 728
 729 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 730 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 731 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 732 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 733 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 734 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 735             if (bb.gt.0.0d0) then
 736               evdw=evdw+sss1*evdwij
 737             else
 738               evdw_t=evdw_t+sss1*evdwij
 739             endif
 740             if (calc_grad) then
 741 C
 742 C Calculate the components of the gradient in DC and X
 743 C
 744             fac=-rrij*(e1+evdwij)*sss1
 745      &          +evdwij*sssgrad1/sqrij/expon
 746             gg(1)=xj*fac
 747             gg(2)=yj*fac
 748             gg(3)=zj*fac
 749             do k=1,3
 750               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 751               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 752             enddo
 753             do k=i,j-1
 754               do l=1,3
 755                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 756               enddo
 757             enddo
 758             endif
 759 #ifdef FOURBODY
 760 C
 761 C 12/1/95, revised on 5/20/97
 762 C
 763 C Calculate the contact function. The ith column of the array JCONT will
 764 C contain the numbers of atoms that make contacts with the atom I (of numbers
 765 C greater than I). The arrays FACONT and GACONT will contain the values of
 766 C the contact function and its derivative.
 767 C
 768 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 769 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 770 C Uncomment next line, if the correlation interactions are contact function only
 771             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 772               rij=dsqrt(rij)
 773               sigij=sigma(itypi,itypj)
 774               r0ij=rs0(itypi,itypj)
 775 C
 776 C Check whether the SC's are not too far to make a contact.
 777 C
 778               rcut=1.5d0*r0ij
 779               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 780 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 781 C
 782               if (fcont.gt.0.0D0) then
 783 C If the SC-SC distance if close to sigma, apply spline.
 784 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 785 cAdam &             fcont1,fprimcont1)
 786 cAdam           fcont1=1.0d0-fcont1
 787 cAdam           if (fcont1.gt.0.0d0) then
 788 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 789 cAdam             fcont=fcont*fcont1
 790 cAdam           endif
 791 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 792 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 793 cga             do k=1,3
 794 cga               gg(k)=gg(k)*eps0ij
 795 cga             enddo
 796 cga             eps0ij=-evdwij*eps0ij
 797 C Uncomment for AL's type of SC correlation interactions.
 798 cadam           eps0ij=-evdwij
 799                 num_conti=num_conti+1
 800                 jcont(num_conti,i)=j
 801                 facont(num_conti,i)=fcont*eps0ij
 802                 fprimcont=eps0ij*fprimcont/rij
 803                 fcont=expon*fcont
 804 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 805 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 806 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 807 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 808                 gacont(1,num_conti,i)=-fprimcont*xj
 809                 gacont(2,num_conti,i)=-fprimcont*yj
 810                 gacont(3,num_conti,i)=-fprimcont*zj
 811 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 812 cd              write (iout,'(2i3,3f10.5)')
 813 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 814               endif
 815             endif
 816 #endif
 817           enddo      ! j
 818         enddo        ! iint
 819 #ifdef FOURBODY
 820 C Change 12/1/95
 821         num_cont(i)=num_conti
 822 #endif
 823       enddo          ! i
 824       if (calc_grad) then
 825       do i=1,nct
 826         do j=1,3
 827           gvdwc(j,i)=expon*gvdwc(j,i)
 828           gvdwx(j,i)=expon*gvdwx(j,i)
 829         enddo
 830       enddo
 831       endif
 832 C******************************************************************************
 833 C
 834 C                              N O T E !!!
 835 C
 836 C To save time, the factor of EXPON has been extracted from ALL components
 837 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 838 C use!
 839 C
 840 C******************************************************************************
 841       return
 842       end
 843 C-----------------------------------------------------------------------------
 844       subroutine eljk(evdw,evdw_t)
 845 C
 846 C This subroutine calculates the interaction energy of nonbonded side chains
 847 C assuming the LJK potential of interaction.
 848 C
 849       implicit real*8 (a-h,o-z)
 850       include 'DIMENSIONS'
 851       include 'DIMENSIONS.ZSCOPT'
 852       include "DIMENSIONS.COMPAR"
 853       include 'COMMON.GEO'
 854       include 'COMMON.VAR'
 855       include 'COMMON.LOCAL'
 856       include 'COMMON.CHAIN'
 857       include 'COMMON.DERIV'
 858       include 'COMMON.INTERACT'
 859       include 'COMMON.ENEPS'
 860       include 'COMMON.IOUNITS'
 861       include 'COMMON.NAMES'
 862       dimension gg(3)
 863       logical scheck
 864       integer icant
 865       external icant
 866 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 867       do i=1,210
 868         do j=1,2
 869           eneps_temp(j,i)=0.0d0
 870         enddo
 871       enddo
 872       evdw=0.0D0
 873       evdw_t=0.0d0
 874       do i=iatsc_s,iatsc_e
 875         itypi=iabs(itype(i))
 876         if (itypi.eq.ntyp1) cycle
 877         itypi1=iabs(itype(i+1))
 878         xi=c(1,nres+i)
 879         yi=c(2,nres+i)
 880         zi=c(3,nres+i)
 881         call to_box(xi,yi,zi)
 882 C
 883 C Calculate SC interaction energy.
 884 C
 885         do iint=1,nint_gr(i)
 886           do j=istart(i,iint),iend(i,iint)
 887             itypj=iabs(itype(j))
 888             if (itypj.eq.ntyp1) cycle
 889             xj=c(1,nres+j)-xi
 890             yj=c(2,nres+j)-yi
 891             zj=c(3,nres+j)-zi
 892             call to_box(xj,yj,zj)
 893             xj=boxshift(xj-xi,boxxsize)
 894             yj=boxshift(yj-yi,boxysize)
 895             zj=boxshift(zj-zi,boxzsize)
 896             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 897             fac_augm=rrij**expon
 898             e_augm=augm(itypi,itypj)*fac_augm
 899             r_inv_ij=dsqrt(rrij)
 900             rij=1.0D0/r_inv_ij
 901             sss1=sscale(rij)
 902             if (sss1.eq.0.0d0) cycle
 903             sssgrad1=sscagrad(rij)
 904             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 905             fac=r_shift_inv**expon
 906             e1=fac*fac*aa
 907             e2=fac*bb
 908             evdwij=e_augm+e1+e2
 909             ij=icant(itypi,itypj)
 910             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 911      &        /dabs(eps(itypi,itypj))
 912             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 913 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 914 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 915 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 916 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 917 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 918 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 919 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 920             if (bb.gt.0.0d0) then
 921               evdw=evdw+evdwij*sss1
 922             else
 923               evdw_t=evdw_t+evdwij*sss1
 924             endif
 925             if (calc_grad) then
 926 C
 927 C Calculate the components of the gradient in DC and X
 928 C
 929            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 930      &          +evdwij*sssgrad1*r_inv_ij/expon
 931             gg(1)=xj*fac
 932             gg(2)=yj*fac
 933             gg(3)=zj*fac
 934             do k=1,3
 935               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 936               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 937             enddo
 938             do k=i,j-1
 939               do l=1,3
 940                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 941               enddo
 942             enddo
 943             endif
 944           enddo      ! j
 945         enddo        ! iint
 946       enddo          ! i
 947       if (calc_grad) then
 948       do i=1,nct
 949         do j=1,3
 950           gvdwc(j,i)=expon*gvdwc(j,i)
 951           gvdwx(j,i)=expon*gvdwx(j,i)
 952         enddo
 953       enddo
 954       endif
 955       return
 956       end
 957 C-----------------------------------------------------------------------------
 958       subroutine ebp(evdw,evdw_t)
 959 C
 960 C This subroutine calculates the interaction energy of nonbonded side chains
 961 C assuming the Berne-Pechukas potential of interaction.
 962 C
 963       implicit real*8 (a-h,o-z)
 964       include 'DIMENSIONS'
 965       include 'DIMENSIONS.ZSCOPT'
 966       include "DIMENSIONS.COMPAR"
 967       include 'COMMON.GEO'
 968       include 'COMMON.VAR'
 969       include 'COMMON.LOCAL'
 970       include 'COMMON.CHAIN'
 971       include 'COMMON.DERIV'
 972       include 'COMMON.NAMES'
 973       include 'COMMON.INTERACT'
 974       include 'COMMON.ENEPS'
 975       include 'COMMON.IOUNITS'
 976       include 'COMMON.CALC'
 977       common /srutu/ icall
 978 c     double precision rrsave(maxdim)
 979       logical lprn
 980       integer icant
 981       external icant
 982       do i=1,210
 983         do j=1,2
 984           eneps_temp(j,i)=0.0d0
 985         enddo
 986       enddo
 987       evdw=0.0D0
 988       evdw_t=0.0d0
 989 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 990 c     if (icall.eq.0) then
 991 c       lprn=.true.
 992 c     else
 993         lprn=.false.
 994 c     endif
 995       ind=0
 996       do i=iatsc_s,iatsc_e
 997         itypi=iabs(itype(i))
 998         if (itypi.eq.ntyp1) cycle
 999         itypi1=iabs(itype(i+1))
1000         xi=c(1,nres+i)
1001         yi=c(2,nres+i)
1002         zi=c(3,nres+i)
1003         call to_box(xi,yi,zi)
1004         dxi=dc_norm(1,nres+i)
1005         dyi=dc_norm(2,nres+i)
1006         dzi=dc_norm(3,nres+i)
1007         dsci_inv=vbld_inv(i+nres)
1008 C
1009 C Calculate SC interaction energy.
1010 C
1011         do iint=1,nint_gr(i)
1012           do j=istart(i,iint),iend(i,iint)
1013             ind=ind+1
1014             itypj=iabs(itype(j))
1015             if (itypj.eq.ntyp1) cycle
1016             dscj_inv=vbld_inv(j+nres)
1017             chi1=chi(itypi,itypj)
1018             chi2=chi(itypj,itypi)
1019             chi12=chi1*chi2
1020             chip1=chip(itypi)
1021             chip2=chip(itypj)
1022             chip12=chip1*chip2
1023             alf1=alp(itypi)
1024             alf2=alp(itypj)
1025             alf12=0.5D0*(alf1+alf2)
1026 C For diagnostics only!!!
1027 c           chi1=0.0D0
1028 c           chi2=0.0D0
1029 c           chi12=0.0D0
1030 c           chip1=0.0D0
1031 c           chip2=0.0D0
1032 c           chip12=0.0D0
1033 c           alf1=0.0D0
1034 c           alf2=0.0D0
1035 c           alf12=0.0D0
1036             xj=c(1,nres+j)
1037             yj=c(2,nres+j)
1038             zj=c(3,nres+j)
1039             call to_box(xj,yj,zj)
1040             xj=boxshift(xj-xi,boxxsize)
1041             yj=boxshift(yj-yi,boxysize)
1042             zj=boxshift(zj-zi,boxzsize)
1043             dxj=dc_norm(1,nres+j)
1044             dyj=dc_norm(2,nres+j)
1045             dzj=dc_norm(3,nres+j)
1046             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1047 cd          if (icall.eq.0) then
1048 cd            rrsave(ind)=rrij
1049 cd          else
1050 cd            rrij=rrsave(ind)
1051 cd          endif
1052             rij=dsqrt(rrij)
1053             sss1=sscale(1.0d0/rij)
1054             if (sss1.eq.0.0d0) cycle
1055             sssgrad1=sscagrad(1.0d0/rij)
1056
1057 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1058             call sc_angular
1059 C Calculate whole angle-dependent part of epsilon and contributions
1060 C to its derivatives
1061             fac=(rrij*sigsq)**expon2
1062             e1=fac*fac*aa
1063             e2=fac*bb
1064             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1065             eps2der=evdwij*eps3rt
1066             eps3der=evdwij*eps2rt
1067             evdwij=evdwij*eps2rt*eps3rt
1068             ij=icant(itypi,itypj)
1069             aux=eps1*eps2rt**2*eps3rt**2
1070             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1071      &        /dabs(eps(itypi,itypj))
1072             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1073             if (bb.gt.0.0d0) then
1074               evdw=evdw+sss1*evdwij
1075             else
1076               evdw_t=evdw_t+sss1*evdwij
1077             endif
1078             if (calc_grad) then
1079             if (lprn) then
1080             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1081             epsi=bb**2/aa
1082             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1083      &        restyp(itypi),i,restyp(itypj),j,
1084      &        epsi,sigm,chi1,chi2,chip1,chip2,
1085      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1086      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1087      &        evdwij
1088             endif
1089 C Calculate gradient components.
1090             e1=e1*eps1*eps2rt**2*eps3rt**2
1091             fac=-expon*(e1+evdwij)
1092             sigder=fac/sigsq
1093             fac=rrij*fac
1094      &           +evdwij*sssgrad1/sss1*rij
1095 C Calculate radial part of the gradient
1096             gg(1)=xj*fac
1097             gg(2)=yj*fac
1098             gg(3)=zj*fac
1099 C Calculate the angular part of the gradient and sum add the contributions
1100 C to the appropriate components of the Cartesian gradient.
1101             call sc_grad
1102             endif
1103           enddo      ! j
1104         enddo        ! iint
1105       enddo          ! i
1106 c     stop
1107       return
1108       end
1109 C-----------------------------------------------------------------------------
1110       subroutine egb(evdw,evdw_t)
1111 C
1112 C This subroutine calculates the interaction energy of nonbonded side chains
1113 C assuming the Gay-Berne potential of interaction.
1114 C
1115       implicit real*8 (a-h,o-z)
1116       include 'DIMENSIONS'
1117       include 'DIMENSIONS.ZSCOPT'
1118       include "DIMENSIONS.COMPAR"
1119       include 'COMMON.CONTROL'
1120       include 'COMMON.GEO'
1121       include 'COMMON.VAR'
1122       include 'COMMON.LOCAL'
1123       include 'COMMON.CHAIN'
1124       include 'COMMON.DERIV'
1125       include 'COMMON.NAMES'
1126       include 'COMMON.INTERACT'
1127       include 'COMMON.ENEPS'
1128       include 'COMMON.IOUNITS'
1129       include 'COMMON.CALC'
1130       include 'COMMON.SBRIDGE'
1131       logical lprn
1132       common /srutu/icall
1133       integer icant,xshift,yshift,zshift
1134       external icant
1135       do i=1,210
1136         do j=1,2
1137           eneps_temp(j,i)=0.0d0
1138         enddo
1139       enddo
1140 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1141       evdw=0.0D0
1142       evdw_t=0.0d0
1143       lprn=.false.
1144 c      if (icall.gt.0) lprn=.true.
1145       ind=0
1146       do i=iatsc_s,iatsc_e
1147         itypi=iabs(itype(i))
1148         if (itypi.eq.ntyp1) cycle
1149         itypi1=iabs(itype(i+1))
1150         xi=c(1,nres+i)
1151         yi=c(2,nres+i)
1152         zi=c(3,nres+i)
1153 C returning the ith atom to box
1154         call to_box(xi,yi,zi)
1155         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1156         dxi=dc_norm(1,nres+i)
1157         dyi=dc_norm(2,nres+i)
1158         dzi=dc_norm(3,nres+i)
1159         dsci_inv=vbld_inv(i+nres)
1160 C
1161 C Calculate SC interaction energy.
1162 C
1163         do iint=1,nint_gr(i)
1164           do j=istart(i,iint),iend(i,iint)
1165             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1166               call dyn_ssbond_ene(i,j,evdwij)
1167               evdw=evdw+evdwij
1168 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1169 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1170 C triple bond artifac removal
1171              do k=j+1,iend(i,iint)
1172 C search over all next residues
1173               if (dyn_ss_mask(k)) then
1174 C check if they are cysteins
1175 C              write(iout,*) 'k=',k
1176               call triple_ssbond_ene(i,j,k,evdwij)
1177 C call the energy function that removes the artifical triple disulfide
1178 C bond the soubroutine is located in ssMD.F
1179               evdw=evdw+evdwij
1180 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1181 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1182               endif!dyn_ss_mask(k)
1183              enddo! k
1184             ELSE
1185             ind=ind+1
1186             itypj=iabs(itype(j))
1187             if (itypj.eq.ntyp1) cycle
1188             dscj_inv=vbld_inv(j+nres)
1189             sig0ij=sigma(itypi,itypj)
1190             chi1=chi(itypi,itypj)
1191             chi2=chi(itypj,itypi)
1192             chi12=chi1*chi2
1193             chip1=chip(itypi)
1194             chip2=chip(itypj)
1195             chip12=chip1*chip2
1196             alf1=alp(itypi)
1197             alf2=alp(itypj)
1198             alf12=0.5D0*(alf1+alf2)
1199 C For diagnostics only!!!
1200 c           chi1=0.0D0
1201 c           chi2=0.0D0
1202 c           chi12=0.0D0
1203 c           chip1=0.0D0
1204 c           chip2=0.0D0
1205 c           chip12=0.0D0
1206 c           alf1=0.0D0
1207 c           alf2=0.0D0
1208 c           alf12=0.0D0
1209             xj=c(1,nres+j)
1210             yj=c(2,nres+j)
1211             zj=c(3,nres+j)
1212 C returning jth atom to box
1213             call to_box(xj,yj,zj)
1214             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1215             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1216      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1217             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1218      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1219 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1220 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
1221 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1222             xj=boxshift(xj-xi,boxxsize)
1223             yj=boxshift(yj-yi,boxysize)
1224             zj=boxshift(zj-zi,boxzsize)
1225             dxj=dc_norm(1,nres+j)
1226             dyj=dc_norm(2,nres+j)
1227             dzj=dc_norm(3,nres+j)
1228 c            write (iout,*) i,j,xj,yj,zj
1229             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1230             rij=dsqrt(rrij)
1231             sss=sscale(1.0d0/rij)
1232             sssgrad=sscagrad(1.0d0/rij)
1233             if (sss.le.0.0) cycle
1234 C Calculate angle-dependent terms of energy and contributions to their
1235 C derivatives.
1236
1237             call sc_angular
1238             sigsq=1.0D0/sigsq
1239             sig=sig0ij*dsqrt(sigsq)
1240             rij_shift=1.0D0/rij-sig+sig0ij
1241 C I hate to put IF's in the loops, but here don't have another choice!!!!
1242             if (rij_shift.le.0.0D0) then
1243               evdw=1.0D20
1244               return
1245             endif
1246             sigder=-sig*sigsq
1247 c---------------------------------------------------------------
1248             rij_shift=1.0D0/rij_shift
1249             fac=rij_shift**expon
1250             e1=fac*fac*aa
1251             e2=fac*bb
1252             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1253             eps2der=evdwij*eps3rt
1254             eps3der=evdwij*eps2rt
1255             evdwij=evdwij*eps2rt*eps3rt
1256             if (bb.gt.0) then
1257               evdw=evdw+evdwij*sss
1258             else
1259               evdw_t=evdw_t+evdwij*sss
1260             endif
1261             ij=icant(itypi,itypj)
1262             aux=eps1*eps2rt**2*eps3rt**2
1263             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1264      &        /dabs(eps(itypi,itypj))
1265             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1266 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1267 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1268 c     &         aux*e2/eps(itypi,itypj)
1269 c            if (lprn) then
1270             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1271             epsi=bb**2/aa
1272 c#define DEBUG
1273 #ifdef DEBUG
1274             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1275      &        restyp(itypi),i,restyp(itypj),j,
1276      &        epsi,sigm,chi1,chi2,chip1,chip2,
1277      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1278      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1279      &        evdwij
1280              write (iout,*) "partial sum", evdw, evdw_t
1281 #endif
1282 c#undef DEBUG
1283 c            endif
1284             if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
1285      &       'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
1286             if (calc_grad) then
1287 C Calculate gradient components.
1288             e1=e1*eps1*eps2rt**2*eps3rt**2
1289             fac=-expon*(e1+evdwij)*rij_shift
1290             sigder=fac*sigder
1291             fac=rij*fac
1292             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1293 C Calculate the radial part of the gradient
1294             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1295      &        *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1296      &         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1297      &        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1298             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1299             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1300             gg(1)=xj*fac
1301             gg(2)=yj*fac
1302             gg(3)=zj*fac
1303 C Calculate angular part of the gradient.
1304             call sc_grad
1305             endif
1306 C            write(iout,*)  "partial sum", evdw, evdw_t
1307             ENDIF    ! dyn_ss
1308           enddo      ! j
1309         enddo        ! iint
1310       enddo          ! i
1311       return
1312       end
1313 C-----------------------------------------------------------------------------
1314       subroutine egbv(evdw,evdw_t)
1315 C
1316 C This subroutine calculates the interaction energy of nonbonded side chains
1317 C assuming the Gay-Berne-Vorobjev potential of interaction.
1318 C
1319       implicit real*8 (a-h,o-z)
1320       include 'DIMENSIONS'
1321       include 'DIMENSIONS.ZSCOPT'
1322       include "DIMENSIONS.COMPAR"
1323       include 'COMMON.GEO'
1324       include 'COMMON.VAR'
1325       include 'COMMON.LOCAL'
1326       include 'COMMON.CHAIN'
1327       include 'COMMON.DERIV'
1328       include 'COMMON.NAMES'
1329       include 'COMMON.INTERACT'
1330       include 'COMMON.ENEPS'
1331       include 'COMMON.IOUNITS'
1332       include 'COMMON.CALC'
1333       common /srutu/ icall
1334       logical lprn
1335       integer icant
1336       external icant
1337       do i=1,210
1338         do j=1,2
1339           eneps_temp(j,i)=0.0d0
1340         enddo
1341       enddo
1342       evdw=0.0D0
1343       evdw_t=0.0d0
1344 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1345       evdw=0.0D0
1346       lprn=.false.
1347 c      if (icall.gt.0) lprn=.true.
1348       ind=0
1349       do i=iatsc_s,iatsc_e
1350         itypi=iabs(itype(i))
1351         if (itypi.eq.ntyp1) cycle
1352         itypi1=iabs(itype(i+1))
1353         xi=c(1,nres+i)
1354         yi=c(2,nres+i)
1355         zi=c(3,nres+i)
1356         call to_box(xi,yi,zi)
1357         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1358         dxi=dc_norm(1,nres+i)
1359         dyi=dc_norm(2,nres+i)
1360         dzi=dc_norm(3,nres+i)
1361         dsci_inv=vbld_inv(i+nres)
1362 C
1363 C Calculate SC interaction energy.
1364 C
1365         do iint=1,nint_gr(i)
1366           do j=istart(i,iint),iend(i,iint)
1367             ind=ind+1
1368             itypj=iabs(itype(j))
1369             if (itypj.eq.ntyp1) cycle
1370             dscj_inv=vbld_inv(j+nres)
1371             sig0ij=sigma(itypi,itypj)
1372             r0ij=r0(itypi,itypj)
1373             chi1=chi(itypi,itypj)
1374             chi2=chi(itypj,itypi)
1375             chi12=chi1*chi2
1376             chip1=chip(itypi)
1377             chip2=chip(itypj)
1378             chip12=chip1*chip2
1379             alf1=alp(itypi)
1380             alf2=alp(itypj)
1381             alf12=0.5D0*(alf1+alf2)
1382 C For diagnostics only!!!
1383 c           chi1=0.0D0
1384 c           chi2=0.0D0
1385 c           chi12=0.0D0
1386 c           chip1=0.0D0
1387 c           chip2=0.0D0
1388 c           chip12=0.0D0
1389 c           alf1=0.0D0
1390 c           alf2=0.0D0
1391 c           alf12=0.0D0
1392             xj=c(1,nres+j)
1393             yj=c(2,nres+j)
1394             zj=c(3,nres+j)
1395             call to_box(xj,yj,zj)
1396             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1397             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1398      &        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1399             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1400      &        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1401 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1402 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1403 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
1404             xj=boxshift(xj-xi,boxxsize)
1405             yj=boxshift(yj-yi,boxysize)
1406             zj=boxshift(zj-zi,boxzsize)
1407             dxj=dc_norm(1,nres+j)
1408             dyj=dc_norm(2,nres+j)
1409             dzj=dc_norm(3,nres+j)
1410             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1411             rij=dsqrt(rrij)
1412             sss=sscale(1.0d0/rij)
1413             if (sss.eq.0.0d0) cycle
1414             sssgrad=sscagrad(1.0d0/rij)
1415 C Calculate angle-dependent terms of energy and contributions to their
1416 C derivatives.
1417             call sc_angular
1418             sigsq=1.0D0/sigsq
1419             sig=sig0ij*dsqrt(sigsq)
1420             rij_shift=1.0D0/rij-sig+r0ij
1421 C I hate to put IF's in the loops, but here don't have another choice!!!!
1422             if (rij_shift.le.0.0D0) then
1423               evdw=1.0D20
1424               return
1425             endif
1426             sigder=-sig*sigsq
1427 c---------------------------------------------------------------
1428             rij_shift=1.0D0/rij_shift
1429             fac=rij_shift**expon
1430             e1=fac*fac*aa
1431             e2=fac*bb
1432             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1433             eps2der=evdwij*eps3rt
1434             eps3der=evdwij*eps2rt
1435             fac_augm=rrij**expon
1436             e_augm=augm(itypi,itypj)*fac_augm
1437             evdwij=evdwij*eps2rt*eps3rt
1438             if (bb.gt.0.0d0) then
1439               evdw=evdw+(evdwij+e_augm)*sss
1440             else
1441               evdw_t=evdw_t+(evdwij+e_augm)*sss
1442             endif
1443             ij=icant(itypi,itypj)
1444             aux=eps1*eps2rt**2*eps3rt**2
1445             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1446      &        /dabs(eps(itypi,itypj))
1447             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1448 c            eneps_temp(ij)=eneps_temp(ij)
1449 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1450 c            if (lprn) then
1451 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1452 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1453 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1454 c     &        restyp(itypi),i,restyp(itypj),j,
1455 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1456 c     &        chi1,chi2,chip1,chip2,
1457 c     &        eps1,eps2rt**2,eps3rt**2,
1458 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1459 c     &        evdwij+e_augm
1460 c            endif
1461             if (calc_grad) then
1462 C Calculate gradient components.
1463             e1=e1*eps1*eps2rt**2*eps3rt**2
1464             fac=-expon*(e1+evdwij)*rij_shift
1465             sigder=fac*sigder
1466             fac=rij*fac-2*expon*rrij*e_augm
1467             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1468 C Calculate the radial part of the gradient
1469             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1470      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1471      &        (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1472      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1473             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1474             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1475             gg(1)=xj*fac
1476             gg(2)=yj*fac
1477             gg(3)=zj*fac
1478 C Calculate angular part of the gradient.
1479             call sc_grad
1480             endif
1481           enddo      ! j
1482         enddo        ! iint
1483       enddo          ! i
1484       return
1485       end
1486 C-----------------------------------------------------------------------------
1487       subroutine sc_angular
1488 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1489 C om12. Called by ebp, egb, and egbv.
1490       implicit none
1491       include 'COMMON.CALC'
1492       erij(1)=xj*rij
1493       erij(2)=yj*rij
1494       erij(3)=zj*rij
1495       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1496       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1497       om12=dxi*dxj+dyi*dyj+dzi*dzj
1498       chiom12=chi12*om12
1499 C Calculate eps1(om12) and its derivative in om12
1500       faceps1=1.0D0-om12*chiom12
1501       faceps1_inv=1.0D0/faceps1
1502       eps1=dsqrt(faceps1_inv)
1503 C Following variable is eps1*deps1/dom12
1504       eps1_om12=faceps1_inv*chiom12
1505 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1506 C and om12.
1507       om1om2=om1*om2
1508       chiom1=chi1*om1
1509       chiom2=chi2*om2
1510       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1511       sigsq=1.0D0-facsig*faceps1_inv
1512       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1513       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1514       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1515 C Calculate eps2 and its derivatives in om1, om2, and om12.
1516       chipom1=chip1*om1
1517       chipom2=chip2*om2
1518       chipom12=chip12*om12
1519       facp=1.0D0-om12*chipom12
1520       facp_inv=1.0D0/facp
1521       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1522 C Following variable is the square root of eps2
1523       eps2rt=1.0D0-facp1*facp_inv
1524 C Following three variables are the derivatives of the square root of eps
1525 C in om1, om2, and om12.
1526       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1527       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1528       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1529 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1530       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1531 C Calculate whole angle-dependent part of epsilon and contributions
1532 C to its derivatives
1533       return
1534       end
1535 C----------------------------------------------------------------------------
1536       subroutine sc_grad
1537       implicit real*8 (a-h,o-z)
1538       include 'DIMENSIONS'
1539       include 'DIMENSIONS.ZSCOPT'
1540       include 'COMMON.CHAIN'
1541       include 'COMMON.DERIV'
1542       include 'COMMON.CALC'
1543       double precision dcosom1(3),dcosom2(3)
1544       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1545       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1546       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1547      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1548       do k=1,3
1549         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1550         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1551       enddo
1552       do k=1,3
1553         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1554       enddo
1555       do k=1,3
1556         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1557      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1558      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1559         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1561      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1562       enddo
1563 C
1564 C Calculate the components of the gradient in DC and X
1565 C
1566       do k=i,j-1
1567         do l=1,3
1568           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1569         enddo
1570       enddo
1571       return
1572       end
1573 c------------------------------------------------------------------------------
1574       subroutine vec_and_deriv
1575       implicit real*8 (a-h,o-z)
1576       include 'DIMENSIONS'
1577       include 'DIMENSIONS.ZSCOPT'
1578       include 'COMMON.IOUNITS'
1579       include 'COMMON.GEO'
1580       include 'COMMON.VAR'
1581       include 'COMMON.LOCAL'
1582       include 'COMMON.CHAIN'
1583       include 'COMMON.VECTORS'
1584       include 'COMMON.DERIV'
1585       include 'COMMON.INTERACT'
1586       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1587 C Compute the local reference systems. For reference system (i), the
1588 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1589 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1590       do i=1,nres-1
1591 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1592           if (i.eq.nres-1) then
1593 C Case of the last full residue
1594 C Compute the Z-axis
1595             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1596             costh=dcos(pi-theta(nres))
1597             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1598 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1599 c     &         " uz",uz(:,i)
1600             do k=1,3
1601               uz(k,i)=fac*uz(k,i)
1602             enddo
1603             if (calc_grad) then
1604 C Compute the derivatives of uz
1605             uzder(1,1,1)= 0.0d0
1606             uzder(2,1,1)=-dc_norm(3,i-1)
1607             uzder(3,1,1)= dc_norm(2,i-1)
1608             uzder(1,2,1)= dc_norm(3,i-1)
1609             uzder(2,2,1)= 0.0d0
1610             uzder(3,2,1)=-dc_norm(1,i-1)
1611             uzder(1,3,1)=-dc_norm(2,i-1)
1612             uzder(2,3,1)= dc_norm(1,i-1)
1613             uzder(3,3,1)= 0.0d0
1614             uzder(1,1,2)= 0.0d0
1615             uzder(2,1,2)= dc_norm(3,i)
1616             uzder(3,1,2)=-dc_norm(2,i)
1617             uzder(1,2,2)=-dc_norm(3,i)
1618             uzder(2,2,2)= 0.0d0
1619             uzder(3,2,2)= dc_norm(1,i)
1620             uzder(1,3,2)= dc_norm(2,i)
1621             uzder(2,3,2)=-dc_norm(1,i)
1622             uzder(3,3,2)= 0.0d0
1623             endif ! calc_grad
1624 C Compute the Y-axis
1625             facy=fac
1626             do k=1,3
1627               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1628             enddo
1629             if (calc_grad) then
1630 C Compute the derivatives of uy
1631             do j=1,3
1632               do k=1,3
1633                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1634      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1635                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1636               enddo
1637               uyder(j,j,1)=uyder(j,j,1)-costh
1638               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1639             enddo
1640             do j=1,2
1641               do k=1,3
1642                 do l=1,3
1643                   uygrad(l,k,j,i)=uyder(l,k,j)
1644                   uzgrad(l,k,j,i)=uzder(l,k,j)
1645                 enddo
1646               enddo
1647             enddo
1648             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1649             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1650             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1651             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1652             endif
1653           else
1654 C Other residues
1655 C Compute the Z-axis
1656             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1657             costh=dcos(pi-theta(i+2))
1658             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1659             do k=1,3
1660               uz(k,i)=fac*uz(k,i)
1661             enddo
1662             if (calc_grad) then
1663 C Compute the derivatives of uz
1664             uzder(1,1,1)= 0.0d0
1665             uzder(2,1,1)=-dc_norm(3,i+1)
1666             uzder(3,1,1)= dc_norm(2,i+1)
1667             uzder(1,2,1)= dc_norm(3,i+1)
1668             uzder(2,2,1)= 0.0d0
1669             uzder(3,2,1)=-dc_norm(1,i+1)
1670             uzder(1,3,1)=-dc_norm(2,i+1)
1671             uzder(2,3,1)= dc_norm(1,i+1)
1672             uzder(3,3,1)= 0.0d0
1673             uzder(1,1,2)= 0.0d0
1674             uzder(2,1,2)= dc_norm(3,i)
1675             uzder(3,1,2)=-dc_norm(2,i)
1676             uzder(1,2,2)=-dc_norm(3,i)
1677             uzder(2,2,2)= 0.0d0
1678             uzder(3,2,2)= dc_norm(1,i)
1679             uzder(1,3,2)= dc_norm(2,i)
1680             uzder(2,3,2)=-dc_norm(1,i)
1681             uzder(3,3,2)= 0.0d0
1682             endif
1683 C Compute the Y-axis
1684             facy=fac
1685             do k=1,3
1686               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1687             enddo
1688             if (calc_grad) then
1689 C Compute the derivatives of uy
1690             do j=1,3
1691               do k=1,3
1692                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1693      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1694                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1695               enddo
1696               uyder(j,j,1)=uyder(j,j,1)-costh
1697               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1698             enddo
1699             do j=1,2
1700               do k=1,3
1701                 do l=1,3
1702                   uygrad(l,k,j,i)=uyder(l,k,j)
1703                   uzgrad(l,k,j,i)=uzder(l,k,j)
1704                 enddo
1705               enddo
1706             enddo
1707             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1708             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1709             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1710             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1711           endif
1712           endif
1713       enddo
1714       if (calc_grad) then
1715       do i=1,nres-1
1716         vbld_inv_temp(1)=vbld_inv(i+1)
1717         if (i.lt.nres-1) then
1718           vbld_inv_temp(2)=vbld_inv(i+2)
1719         else
1720           vbld_inv_temp(2)=vbld_inv(i)
1721         endif
1722         do j=1,2
1723           do k=1,3
1724             do l=1,3
1725               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1726               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1727             enddo
1728           enddo
1729         enddo
1730       enddo
1731       endif
1732       return
1733       end
1734 C--------------------------------------------------------------------------
1735       subroutine set_matrices
1736       implicit real*8 (a-h,o-z)
1737       include 'DIMENSIONS'
1738 #ifdef MPI
1739       include "mpif.h"
1740       integer IERR
1741       integer status(MPI_STATUS_SIZE)
1742 #endif
1743       include 'DIMENSIONS.ZSCOPT'
1744       include 'COMMON.IOUNITS'
1745       include 'COMMON.GEO'
1746       include 'COMMON.VAR'
1747       include 'COMMON.LOCAL'
1748       include 'COMMON.CHAIN'
1749       include 'COMMON.DERIV'
1750       include 'COMMON.INTERACT'
1751       include 'COMMON.CORRMAT'
1752       include 'COMMON.TORSION'
1753       include 'COMMON.VECTORS'
1754       include 'COMMON.FFIELD'
1755       double precision auxvec(2),auxmat(2,2)
1756 C
1757 C Compute the virtual-bond-torsional-angle dependent quantities needed
1758 C to calculate the el-loc multibody terms of various order.
1759 C
1760 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1761       do i=3,nres+1
1762         ii=ireschain(i-2)
1763         if (ii.eq.0) cycle
1764         innt=chain_border(1,ii)
1765         inct=chain_border(2,ii)
1766 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1767         if (i.gt. innt+2 .and. i.lt.inct+2) then
1768           iti = itype2loc(itype(i-2))
1769         else
1770           iti=nloctyp
1771         endif
1772 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1773 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1774         if (i.gt. innt+1 .and. i.lt.inct+1) then
1775           iti1 = itype2loc(itype(i-1))
1776         else
1777           iti1=nloctyp
1778         endif
1779 #ifdef NEWCORR
1780         cost1=dcos(theta(i-1))
1781         sint1=dsin(theta(i-1))
1782         sint1sq=sint1*sint1
1783         sint1cub=sint1sq*sint1
1784         sint1cost1=2*sint1*cost1
1785 #ifdef DEBUG
1786         write (iout,*) "bnew1",i,iti
1787         write (iout,*) (bnew1(k,1,iti),k=1,3)
1788         write (iout,*) (bnew1(k,2,iti),k=1,3)
1789         write (iout,*) "bnew2",i,iti
1790         write (iout,*) (bnew2(k,1,iti),k=1,3)
1791         write (iout,*) (bnew2(k,2,iti),k=1,3)
1792 #endif
1793         do k=1,2
1794           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1795           b1(k,i-2)=sint1*b1k
1796           gtb1(k,i-2)=cost1*b1k-sint1sq*
1797      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1798           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1799           b2(k,i-2)=sint1*b2k
1800           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1801      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1802         enddo
1803         do k=1,2
1804           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1805           cc(1,k,i-2)=sint1sq*aux
1806           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1807      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1808           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1809           dd(1,k,i-2)=sint1sq*aux
1810           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1811      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1812         enddo
1813         cc(2,1,i-2)=cc(1,2,i-2)
1814         cc(2,2,i-2)=-cc(1,1,i-2)
1815         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1816         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1817         dd(2,1,i-2)=dd(1,2,i-2)
1818         dd(2,2,i-2)=-dd(1,1,i-2)
1819         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1820         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1821         do k=1,2
1822           do l=1,2
1823             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1824             EE(l,k,i-2)=sint1sq*aux
1825             if (calc_grad)
1826      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1827           enddo
1828         enddo
1829         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1830         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1831         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1832         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1833         if (calc_grad) then
1834         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1835         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1836         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1837         endif
1838 c        b1tilde(1,i-2)=b1(1,i-2)
1839 c        b1tilde(2,i-2)=-b1(2,i-2)
1840 c        b2tilde(1,i-2)=b2(1,i-2)
1841 c        b2tilde(2,i-2)=-b2(2,i-2)
1842 #ifdef DEBUG
1843         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1844         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1845         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1846         write (iout,*) 'theta=', theta(i-1)
1847 #endif
1848 #else
1849 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1850 c          iti = itype2loc(itype(i-2))
1851 c        else
1852 c          iti=nloctyp
1853 c        endif
1854 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1855 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1856 c          iti1 = itype2loc(itype(i-1))
1857 c        else
1858 c          iti1=nloctyp
1859 c        endif
1860         b1(1,i-2)=b(3,iti)
1861         b1(2,i-2)=b(5,iti)
1862         b2(1,i-2)=b(2,iti)
1863         b2(2,i-2)=b(4,iti)
1864         do k=1,2
1865           do l=1,2
1866            CC(k,l,i-2)=ccold(k,l,iti)
1867            DD(k,l,i-2)=ddold(k,l,iti)
1868            EE(k,l,i-2)=eeold(k,l,iti)
1869           enddo
1870         enddo
1871 #endif
1872         b1tilde(1,i-2)= b1(1,i-2)
1873         b1tilde(2,i-2)=-b1(2,i-2)
1874         b2tilde(1,i-2)= b2(1,i-2)
1875         b2tilde(2,i-2)=-b2(2,i-2)
1876 c
1877         Ctilde(1,1,i-2)= CC(1,1,i-2)
1878         Ctilde(1,2,i-2)= CC(1,2,i-2)
1879         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1880         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1881 c
1882         Dtilde(1,1,i-2)= DD(1,1,i-2)
1883         Dtilde(1,2,i-2)= DD(1,2,i-2)
1884         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1885         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1886 #ifdef DEBUG
1887         write(iout,*) "i",i," iti",iti
1888         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1889         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1890 #endif
1891       enddo
1892       do i=3,nres+1
1893         if (i .lt. nres+1) then
1894           sin1=dsin(phi(i))
1895           cos1=dcos(phi(i))
1896           sintab(i-2)=sin1
1897           costab(i-2)=cos1
1898           obrot(1,i-2)=cos1
1899           obrot(2,i-2)=sin1
1900           sin2=dsin(2*phi(i))
1901           cos2=dcos(2*phi(i))
1902           sintab2(i-2)=sin2
1903           costab2(i-2)=cos2
1904           obrot2(1,i-2)=cos2
1905           obrot2(2,i-2)=sin2
1906           Ug(1,1,i-2)=-cos1
1907           Ug(1,2,i-2)=-sin1
1908           Ug(2,1,i-2)=-sin1
1909           Ug(2,2,i-2)= cos1
1910           Ug2(1,1,i-2)=-cos2
1911           Ug2(1,2,i-2)=-sin2
1912           Ug2(2,1,i-2)=-sin2
1913           Ug2(2,2,i-2)= cos2
1914         else
1915           costab(i-2)=1.0d0
1916           sintab(i-2)=0.0d0
1917           obrot(1,i-2)=1.0d0
1918           obrot(2,i-2)=0.0d0
1919           obrot2(1,i-2)=0.0d0
1920           obrot2(2,i-2)=0.0d0
1921           Ug(1,1,i-2)=1.0d0
1922           Ug(1,2,i-2)=0.0d0
1923           Ug(2,1,i-2)=0.0d0
1924           Ug(2,2,i-2)=1.0d0
1925           Ug2(1,1,i-2)=0.0d0
1926           Ug2(1,2,i-2)=0.0d0
1927           Ug2(2,1,i-2)=0.0d0
1928           Ug2(2,2,i-2)=0.0d0
1929         endif
1930         if (i .gt. 3 .and. i .lt. nres+1) then
1931           obrot_der(1,i-2)=-sin1
1932           obrot_der(2,i-2)= cos1
1933           Ugder(1,1,i-2)= sin1
1934           Ugder(1,2,i-2)=-cos1
1935           Ugder(2,1,i-2)=-cos1
1936           Ugder(2,2,i-2)=-sin1
1937           dwacos2=cos2+cos2
1938           dwasin2=sin2+sin2
1939           obrot2_der(1,i-2)=-dwasin2
1940           obrot2_der(2,i-2)= dwacos2
1941           Ug2der(1,1,i-2)= dwasin2
1942           Ug2der(1,2,i-2)=-dwacos2
1943           Ug2der(2,1,i-2)=-dwacos2
1944           Ug2der(2,2,i-2)=-dwasin2
1945         else
1946           obrot_der(1,i-2)=0.0d0
1947           obrot_der(2,i-2)=0.0d0
1948           Ugder(1,1,i-2)=0.0d0
1949           Ugder(1,2,i-2)=0.0d0
1950           Ugder(2,1,i-2)=0.0d0
1951           Ugder(2,2,i-2)=0.0d0
1952           obrot2_der(1,i-2)=0.0d0
1953           obrot2_der(2,i-2)=0.0d0
1954           Ug2der(1,1,i-2)=0.0d0
1955           Ug2der(1,2,i-2)=0.0d0
1956           Ug2der(2,1,i-2)=0.0d0
1957           Ug2der(2,2,i-2)=0.0d0
1958         endif
1959 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1960         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1961           iti = itype2loc(itype(i-2))
1962         else
1963           iti=nloctyp
1964         endif
1965 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1966         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1967           iti1 = itype2loc(itype(i-1))
1968         else
1969           iti1=nloctyp
1970         endif
1971 cd        write (iout,*) '*******i',i,' iti1',iti
1972 cd        write (iout,*) 'b1',b1(:,iti)
1973 cd        write (iout,*) 'b2',b2(:,iti)
1974 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1975 c        if (i .gt. iatel_s+2) then
1976         if (i .gt. nnt+2) then
1977           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1978 #ifdef NEWCORR
1979           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1980 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1981 #endif
1982 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1983 c     &    EE(1,2,iti),EE(2,2,i)
1984           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1985           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1986 c          write(iout,*) "Macierz EUG",
1987 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1988 c     &    eug(2,2,i-2)
1989 #ifdef FOURBODY
1990           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1991      &    then
1992           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1993           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1994           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1995           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1996           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1997           endif
1998 #endif
1999         else
2000           do k=1,2
2001             Ub2(k,i-2)=0.0d0
2002             Ctobr(k,i-2)=0.0d0
2003             Dtobr2(k,i-2)=0.0d0
2004             do l=1,2
2005               EUg(l,k,i-2)=0.0d0
2006               CUg(l,k,i-2)=0.0d0
2007               DUg(l,k,i-2)=0.0d0
2008               DtUg2(l,k,i-2)=0.0d0
2009             enddo
2010           enddo
2011         endif
2012         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2013         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2014         do k=1,2
2015           muder(k,i-2)=Ub2der(k,i-2)
2016         enddo
2017 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2018         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2019           if (itype(i-1).le.ntyp) then
2020             iti1 = itype2loc(itype(i-1))
2021           else
2022             iti1=nloctyp
2023           endif
2024         else
2025           iti1=nloctyp
2026         endif
2027         do k=1,2
2028           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2029         enddo
2030 #ifdef MUOUT
2031         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2032      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2033      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2034      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2035      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2036      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2037 #endif
2038 cd        write (iout,*) 'mu1',mu1(:,i-2)
2039 cd        write (iout,*) 'mu2',mu2(:,i-2)
2040 #ifdef FOURBODY
2041         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2042      &  then
2043         if (calc_grad) then
2044         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2045         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2046         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2047         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2048         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2049         endif
2050 C Vectors and matrices dependent on a single virtual-bond dihedral.
2051         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2052         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2053         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2054         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2055         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2056         if (calc_grad) then
2057         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2058         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2059         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2060         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2061         endif
2062         endif
2063 #endif
2064       enddo
2065 #ifdef FOURBODY
2066 C Matrices dependent on two consecutive virtual-bond dihedrals.
2067 C The order of matrices is from left to right.
2068       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2069      &then
2070       do i=2,nres-1
2071         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2072         if (calc_grad) then
2073         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2074         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2075         endif
2076         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2077         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2078         if (calc_grad) then
2079         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2080         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2081         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2082         endif
2083       enddo
2084       endif
2085 #endif
2086       return
2087       end
2088 C--------------------------------------------------------------------------
2089       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2090 C
2091 C This subroutine calculates the average interaction energy and its gradient
2092 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2093 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2094 C The potential depends both on the distance of peptide-group centers and on
2095 C the orientation of the CA-CA virtual bonds.
2096 C
2097       implicit real*8 (a-h,o-z)
2098 #ifdef MPI
2099       include 'mpif.h'
2100 #endif
2101       include 'DIMENSIONS'
2102       include 'DIMENSIONS.ZSCOPT'
2103       include 'COMMON.CONTROL'
2104       include 'COMMON.IOUNITS'
2105       include 'COMMON.GEO'
2106       include 'COMMON.VAR'
2107       include 'COMMON.LOCAL'
2108       include 'COMMON.CHAIN'
2109       include 'COMMON.DERIV'
2110       include 'COMMON.INTERACT'
2111 #ifdef FOURBODY
2112       include 'COMMON.CONTACTS'
2113       include 'COMMON.CONTMAT'
2114 #endif
2115       include 'COMMON.CORRMAT'
2116       include 'COMMON.TORSION'
2117       include 'COMMON.VECTORS'
2118       include 'COMMON.FFIELD'
2119       include 'COMMON.TIME1'
2120       include 'COMMON.SPLITELE'
2121       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2122      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2123       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2124      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2125       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2126      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2127      &    num_conti,j1,j2
2128       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
2129       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
2130 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2131 #ifdef MOMENT
2132       double precision scal_el /1.0d0/
2133 #else
2134       double precision scal_el /0.5d0/
2135 #endif
2136 C 12/13/98
2137 C 13-go grudnia roku pamietnego...
2138       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2139      &                   0.0d0,1.0d0,0.0d0,
2140      &                   0.0d0,0.0d0,1.0d0/
2141 cd      write(iout,*) 'In EELEC'
2142 cd      do i=1,nloctyp
2143 cd        write(iout,*) 'Type',i
2144 cd        write(iout,*) 'B1',B1(:,i)
2145 cd        write(iout,*) 'B2',B2(:,i)
2146 cd        write(iout,*) 'CC',CC(:,:,i)
2147 cd        write(iout,*) 'DD',DD(:,:,i)
2148 cd        write(iout,*) 'EE',EE(:,:,i)
2149 cd      enddo
2150 cd      call check_vecgrad
2151 cd      stop
2152       if (icheckgrad.eq.1) then
2153         do i=1,nres-1
2154           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2155           do k=1,3
2156             dc_norm(k,i)=dc(k,i)*fac
2157           enddo
2158 c          write (iout,*) 'i',i,' fac',fac
2159         enddo
2160       endif
2161       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2162      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2163      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2164 c        call vec_and_deriv
2165 #ifdef TIMING
2166         time01=MPI_Wtime()
2167 #endif
2168         call set_matrices
2169 #ifdef TIMING
2170         time_mat=time_mat+MPI_Wtime()-time01
2171 #endif
2172       endif
2173 cd      do i=1,nres-1
2174 cd        write (iout,*) 'i=',i
2175 cd        do k=1,3
2176 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2177 cd        enddo
2178 cd        do k=1,3
2179 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2180 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2181 cd        enddo
2182 cd      enddo
2183       t_eelecij=0.0d0
2184       ees=0.0D0
2185       evdw1=0.0D0
2186       eel_loc=0.0d0
2187       eello_turn3=0.0d0
2188       eello_turn4=0.0d0
2189       ind=0
2190 #ifdef FOURBODY
2191       do i=1,nres
2192         num_cont_hb(i)=0
2193       enddo
2194 #endif
2195 cd      print '(a)','Enter EELEC'
2196 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2197       do i=1,nres
2198         gel_loc_loc(i)=0.0d0
2199         gcorr_loc(i)=0.0d0
2200       enddo
2201 c
2202 c
2203 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2204 C
2205 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2206 C
2207 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2208       do i=iturn3_start,iturn3_end
2209 c        if (i.le.1) cycle
2210 C        write(iout,*) "tu jest i",i
2211         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2212 C changes suggested by Ana to avoid out of bounds
2213 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2214 c     & .or.((i+4).gt.nres)
2215 c     & .or.((i-1).le.0)
2216 C end of changes by Ana
2217 C dobra zmiana wycofana
2218      &  .or. itype(i+2).eq.ntyp1
2219      &  .or. itype(i+3).eq.ntyp1) cycle
2220 C Adam: Instructions below will switch off existing interactions
2221 c        if(i.gt.1)then
2222 c          if(itype(i-1).eq.ntyp1)cycle
2223 c        end if
2224 c        if(i.LT.nres-3)then
2225 c          if (itype(i+4).eq.ntyp1) cycle
2226 c        end if
2227         dxi=dc(1,i)
2228         dyi=dc(2,i)
2229         dzi=dc(3,i)
2230         dx_normi=dc_norm(1,i)
2231         dy_normi=dc_norm(2,i)
2232         dz_normi=dc_norm(3,i)
2233         xmedi=c(1,i)+0.5d0*dxi
2234         ymedi=c(2,i)+0.5d0*dyi
2235         zmedi=c(3,i)+0.5d0*dzi
2236         call to_box(xmedi,ymedi,zmedi)
2237         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2238         num_conti=0
2239         call eelecij(i,i+2,ees,evdw1,eel_loc)
2240         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2241 #ifdef FOURBODY
2242         num_cont_hb(i)=num_conti
2243 #endif
2244       enddo
2245       do i=iturn4_start,iturn4_end
2246         if (i.lt.1) cycle
2247         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2248 C changes suggested by Ana to avoid out of bounds
2249 c     & .or.((i+5).gt.nres)
2250 c     & .or.((i-1).le.0)
2251 C end of changes suggested by Ana
2252      &    .or. itype(i+3).eq.ntyp1
2253      &    .or. itype(i+4).eq.ntyp1
2254 c     &    .or. itype(i+5).eq.ntyp1
2255 c     &    .or. itype(i).eq.ntyp1
2256 c     &    .or. itype(i-1).eq.ntyp1
2257      &                             ) cycle
2258         dxi=dc(1,i)
2259         dyi=dc(2,i)
2260         dzi=dc(3,i)
2261         dx_normi=dc_norm(1,i)
2262         dy_normi=dc_norm(2,i)
2263         dz_normi=dc_norm(3,i)
2264         xmedi=c(1,i)+0.5d0*dxi
2265         ymedi=c(2,i)+0.5d0*dyi
2266         zmedi=c(3,i)+0.5d0*dzi
2267         call to_box(xmedi,ymedi,zmedi)
2268         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2269 #ifdef FOURBODY
2270         num_conti=num_cont_hb(i)
2271 #endif
2272 c        write(iout,*) "JESTEM W PETLI"
2273         call eelecij(i,i+3,ees,evdw1,eel_loc)
2274         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2275      &   call eturn4(i,eello_turn4)
2276 c        write (iout,*) "i",i," eello_turn4",eello_turn4
2277 #ifdef FOURBODY
2278         num_cont_hb(i)=num_conti
2279 #endif
2280       enddo   ! i
2281 C Loop over all neighbouring boxes
2282 C      do xshift=-1,1
2283 C      do yshift=-1,1
2284 C      do zshift=-1,1
2285 c
2286 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2287 c
2288 CTU KURWA
2289       do i=iatel_s,iatel_e
2290 C        do i=75,75
2291 c        if (i.le.1) cycle
2292         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2293 C changes suggested by Ana to avoid out of bounds
2294 c     & .or.((i+2).gt.nres)
2295 c     & .or.((i-1).le.0)
2296 C end of changes by Ana
2297 c     &  .or. itype(i+2).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         call to_box(xmedi,ymedi,zmedi)
2310         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
2311 #ifdef FOURBODY
2312         num_conti=num_cont_hb(i)
2313 #endif
2314 C I TU KURWA
2315         do j=ielstart(i),ielend(i)
2316 C          do j=16,17
2317 C          write (iout,*) i,j
2318 C         if (j.le.1) cycle
2319           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2320 C changes suggested by Ana to avoid out of bounds
2321 c     & .or.((j+2).gt.nres)
2322 c     & .or.((j-1).le.0)
2323 C end of changes by Ana
2324 c     & .or.itype(j+2).eq.ntyp1
2325 c     & .or.itype(j-1).eq.ntyp1
2326      &) cycle
2327           call eelecij(i,j,ees,evdw1,eel_loc)
2328         enddo ! j
2329 #ifdef FOURBODY
2330         num_cont_hb(i)=num_conti
2331 #endif
2332       enddo   ! i
2333 C     enddo   ! zshift
2334 C      enddo   ! yshift
2335 C      enddo   ! xshift
2336
2337 c      write (iout,*) "Number of loop steps in EELEC:",ind
2338 cd      do i=1,nres
2339 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2340 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2341 cd      enddo
2342 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2343 ccc      eel_loc=eel_loc+eello_turn3
2344 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2345       return
2346       end
2347 C-------------------------------------------------------------------------------
2348       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2349       implicit real*8 (a-h,o-z)
2350       include 'DIMENSIONS'
2351       include 'DIMENSIONS.ZSCOPT'
2352 #ifdef MPI
2353       include "mpif.h"
2354 #endif
2355       include 'COMMON.CONTROL'
2356       include 'COMMON.IOUNITS'
2357       include 'COMMON.GEO'
2358       include 'COMMON.VAR'
2359       include 'COMMON.LOCAL'
2360       include 'COMMON.CHAIN'
2361       include 'COMMON.DERIV'
2362       include 'COMMON.INTERACT'
2363 #ifdef FOURBODY
2364       include 'COMMON.CONTACTS'
2365       include 'COMMON.CONTMAT'
2366 #endif
2367       include 'COMMON.CORRMAT'
2368       include 'COMMON.TORSION'
2369       include 'COMMON.VECTORS'
2370       include 'COMMON.FFIELD'
2371       include 'COMMON.TIME1'
2372       include 'COMMON.SPLITELE'
2373       include 'COMMON.SHIELD'
2374       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2375      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2376       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2377      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2378      &    gmuij2(4),gmuji2(4)
2379       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2380      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2381      &    num_conti,j1,j2
2382       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
2383      & faclipij2
2384       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
2385 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2386 #ifdef MOMENT
2387       double precision scal_el /1.0d0/
2388 #else
2389       double precision scal_el /0.5d0/
2390 #endif
2391 C 12/13/98
2392 C 13-go grudnia roku pamietnego...
2393       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2394      &                   0.0d0,1.0d0,0.0d0,
2395      &                   0.0d0,0.0d0,1.0d0/
2396        integer xshift,yshift,zshift
2397 c          time00=MPI_Wtime()
2398 cd      write (iout,*) "eelecij",i,j
2399 c          ind=ind+1
2400           iteli=itel(i)
2401           itelj=itel(j)
2402           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2403           aaa=app(iteli,itelj)
2404           bbb=bpp(iteli,itelj)
2405           ael6i=ael6(iteli,itelj)
2406           ael3i=ael3(iteli,itelj)
2407           dxj=dc(1,j)
2408           dyj=dc(2,j)
2409           dzj=dc(3,j)
2410           dx_normj=dc_norm(1,j)
2411           dy_normj=dc_norm(2,j)
2412           dz_normj=dc_norm(3,j)
2413 C          xj=c(1,j)+0.5D0*dxj-xmedi
2414 C          yj=c(2,j)+0.5D0*dyj-ymedi
2415 C          zj=c(3,j)+0.5D0*dzj-zmedi
2416           xj=c(1,j)+0.5D0*dxj
2417           yj=c(2,j)+0.5D0*dyj
2418           zj=c(3,j)+0.5D0*dzj
2419           call to_box(xj,yj,zj)
2420           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2421           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
2422           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
2423           xj=boxshift(xj-xmedi,boxxsize)
2424           yj=boxshift(yj-ymedi,boxysize)
2425           zj=boxshift(zj-zmedi,boxzsize)
2426           rij=xj*xj+yj*yj+zj*zj
2427
2428           sss=sscale(sqrt(rij))
2429           if (sss.eq.0.0d0) return
2430           sssgrad=sscagrad(sqrt(rij))
2431 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2432 c     &       " rlamb",rlamb," sss",sss
2433 c            if (sss.gt.0.0d0) then
2434           rrmij=1.0D0/rij
2435           rij=dsqrt(rij)
2436           rmij=1.0D0/rij
2437           r3ij=rrmij*rmij
2438           r6ij=r3ij*r3ij
2439           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2440           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2441           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2442           fac=cosa-3.0D0*cosb*cosg
2443           ev1=aaa*r6ij*r6ij
2444 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2445           if (j.eq.i+2) ev1=scal_el*ev1
2446           ev2=bbb*r6ij
2447           fac3=ael6i*r6ij
2448           fac4=ael3i*r3ij
2449           evdwij=(ev1+ev2)
2450           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2451           el2=fac4*fac
2452 C MARYSIA
2453 C          eesij=(el1+el2)
2454 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2455           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2456           if (shield_mode.gt.0) then
2457 C          fac_shield(i)=0.4
2458 C          fac_shield(j)=0.6
2459           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2460           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2461           eesij=(el1+el2)
2462           ees=ees+eesij*sss*faclipij2
2463           else
2464           fac_shield(i)=1.0
2465           fac_shield(j)=1.0
2466           eesij=(el1+el2)
2467           ees=ees+eesij*sss*faclipij2
2468           endif
2469           evdw1=evdw1+evdwij*sss*faclipij2
2470 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2471 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2472 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2473 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2474
2475           if (energy_dec) then
2476             write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2477      &'       evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss
2478             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
2479      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
2480      &        faclipij2
2481           endif
2482
2483 C
2484 C Calculate contributions to the Cartesian gradient.
2485 C
2486 #ifdef SPLITELE
2487           facvdw=-6*rrmij*(ev1+evdwij)*sss
2488           facel=-3*rrmij*(el1+eesij)
2489           fac1=fac
2490           erij(1)=xj*rmij
2491           erij(2)=yj*rmij
2492           erij(3)=zj*rmij
2493
2494 *
2495 * Radial derivatives. First process both termini of the fragment (i,j)
2496 *
2497           if (calc_grad) then
2498           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
2499           ggg(1)=aux*xj
2500           ggg(2)=aux*yj
2501           ggg(3)=aux*zj
2502           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2503      &  (shield_mode.gt.0)) then
2504 C          print *,i,j
2505           do ilist=1,ishield_list(i)
2506            iresshield=shield_list(ilist,i)
2507            do k=1,3
2508            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2509      &      *2.0
2510            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2511      &              rlocshield
2512      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2513             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2514 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2515 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2516 C             if (iresshield.gt.i) then
2517 C               do ishi=i+1,iresshield-1
2518 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2519 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2520 C
2521 C              enddo
2522 C             else
2523 C               do ishi=iresshield,i
2524 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2525 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2526 C
2527 C               enddo
2528 C              endif
2529            enddo
2530           enddo
2531           do ilist=1,ishield_list(j)
2532            iresshield=shield_list(ilist,j)
2533            do k=1,3
2534            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2535      &     *2.0
2536            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2537      &              rlocshield
2538      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2539            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2540
2541 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2542 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2543 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2544 C             if (iresshield.gt.j) then
2545 C               do ishi=j+1,iresshield-1
2546 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2547 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2548 C
2549 C               enddo
2550 C            else
2551 C               do ishi=iresshield,j
2552 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2553 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2554 C               enddo
2555 C              endif
2556            enddo
2557           enddo
2558
2559           do k=1,3
2560             gshieldc(k,i)=gshieldc(k,i)+
2561      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2562             gshieldc(k,j)=gshieldc(k,j)+
2563      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2564             gshieldc(k,i-1)=gshieldc(k,i-1)+
2565      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2566             gshieldc(k,j-1)=gshieldc(k,j-1)+
2567      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2568
2569            enddo
2570            endif
2571 c          do k=1,3
2572 c            ghalf=0.5D0*ggg(k)
2573 c            gelc(k,i)=gelc(k,i)+ghalf
2574 c            gelc(k,j)=gelc(k,j)+ghalf
2575 c          enddo
2576 c 9/28/08 AL Gradient compotents will be summed only at the end
2577 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2578           do k=1,3
2579             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2580 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2581             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2582 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2583 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2584 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2585 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2586 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2587           gelc_long(3,j)=gelc_long(3,j)+
2588      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
2589
2590           gelc_long(3,i)=gelc_long(3,i)+
2591      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
2592           enddo
2593 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2594
2595 *
2596 * Loop over residues i+1 thru j-1.
2597 *
2598 cgrad          do k=i+1,j-1
2599 cgrad            do l=1,3
2600 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2601 cgrad            enddo
2602 cgrad          enddo
2603           if (sss.gt.0.0) then
2604           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
2605           ggg(1)=facvdw*xj
2606           ggg(2)=facvdw*yj
2607           ggg(3)=facvdw*zj
2608           else
2609           ggg(1)=0.0
2610           ggg(2)=0.0
2611           ggg(3)=0.0
2612           endif
2613 c          do k=1,3
2614 c            ghalf=0.5D0*ggg(k)
2615 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2616 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2617 c          enddo
2618 c 9/28/08 AL Gradient compotents will be summed only at the end
2619           do k=1,3
2620             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2621             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2622           enddo
2623 !C Lipidic part for scaling weight
2624           gvdwpp(3,j)=gvdwpp(3,j)+
2625      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
2626           gvdwpp(3,i)=gvdwpp(3,i)+
2627      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
2628 *
2629 * Loop over residues i+1 thru j-1.
2630 *
2631 cgrad          do k=i+1,j-1
2632 cgrad            do l=1,3
2633 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2634 cgrad            enddo
2635 cgrad          enddo
2636           endif ! calc_grad
2637 #else
2638 C MARYSIA
2639           facvdw=(ev1+evdwij)*faclipij2
2640           facel=(el1+eesij)
2641           fac1=fac
2642           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2643      &       +(evdwij+eesij)*sssgrad*rrmij
2644           erij(1)=xj*rmij
2645           erij(2)=yj*rmij
2646           erij(3)=zj*rmij
2647 *
2648 * Radial derivatives. First process both termini of the fragment (i,j)
2649 *
2650           if (calc_grad) then
2651           ggg(1)=fac*xj
2652 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2653           ggg(2)=fac*yj
2654 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2655           ggg(3)=fac*zj
2656 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2657 c          do k=1,3
2658 c            ghalf=0.5D0*ggg(k)
2659 c            gelc(k,i)=gelc(k,i)+ghalf
2660 c            gelc(k,j)=gelc(k,j)+ghalf
2661 c          enddo
2662 c 9/28/08 AL Gradient compotents will be summed only at the end
2663           do k=1,3
2664             gelc_long(k,j)=gelc(k,j)+ggg(k)
2665             gelc_long(k,i)=gelc(k,i)-ggg(k)
2666           enddo
2667 *
2668 * Loop over residues i+1 thru j-1.
2669 *
2670 cgrad          do k=i+1,j-1
2671 cgrad            do l=1,3
2672 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2673 cgrad            enddo
2674 cgrad          enddo
2675 c 9/28/08 AL Gradient compotents will be summed only at the end
2676           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2677           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2678           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2679           do k=1,3
2680             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2681             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2682           enddo
2683           gvdwpp(3,j)=gvdwpp(3,j)+
2684      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
2685           gvdwpp(3,i)=gvdwpp(3,i)+
2686      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
2687           endif ! calc_grad
2688 #endif
2689 *
2690 * Angular part
2691 *
2692           if (calc_grad) then
2693           ecosa=2.0D0*fac3*fac1+fac4
2694           fac4=-3.0D0*fac4
2695           fac3=-6.0D0*fac3
2696           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2697           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2698           do k=1,3
2699             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2700             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2701           enddo
2702 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2703 cd   &          (dcosg(k),k=1,3)
2704           do k=1,3
2705             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2706      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
2707           enddo
2708 c          do k=1,3
2709 c            ghalf=0.5D0*ggg(k)
2710 c            gelc(k,i)=gelc(k,i)+ghalf
2711 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2712 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2713 c            gelc(k,j)=gelc(k,j)+ghalf
2714 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2715 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2716 c          enddo
2717 cgrad          do k=i+1,j-1
2718 cgrad            do l=1,3
2719 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2720 cgrad            enddo
2721 cgrad          enddo
2722 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2723           do k=1,3
2724             gelc(k,i)=gelc(k,i)
2725      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2726      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2727      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2728             gelc(k,j)=gelc(k,j)
2729      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2730      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2731      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
2732             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2733             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2734           enddo
2735 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2736
2737 C MARYSIA
2738 c          endif !sscale
2739           endif ! calc_grad
2740           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2741      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2742      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2743 C
2744 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2745 C   energy of a peptide unit is assumed in the form of a second-order
2746 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2747 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2748 C   are computed for EVERY pair of non-contiguous peptide groups.
2749 C
2750
2751           if (j.lt.nres-1) then
2752             j1=j+1
2753             j2=j-1
2754           else
2755             j1=j-1
2756             j2=j-2
2757           endif
2758           kkk=0
2759           lll=0
2760           do k=1,2
2761             do l=1,2
2762               kkk=kkk+1
2763               muij(kkk)=mu(k,i)*mu(l,j)
2764 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2765 #ifdef NEWCORR
2766              if (calc_grad) then
2767              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2768 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2769              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2770              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2771 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2772              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2773              endif
2774 #endif
2775             enddo
2776           enddo
2777 #ifdef DEBUG
2778           write (iout,*) 'EELEC: i',i,' j',j
2779           write (iout,*) 'j',j,' j1',j1,' j2',j2
2780           write(iout,*) 'muij',muij
2781           write (iout,*) "uy",uy(:,i)
2782           write (iout,*) "uz",uz(:,j)
2783           write (iout,*) "erij",erij
2784 #endif
2785           ury=scalar(uy(1,i),erij)
2786           urz=scalar(uz(1,i),erij)
2787           vry=scalar(uy(1,j),erij)
2788           vrz=scalar(uz(1,j),erij)
2789           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2790           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2791           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2792           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2793           fac=dsqrt(-ael6i)*r3ij
2794           a22=a22*fac
2795           a23=a23*fac
2796           a32=a32*fac
2797           a33=a33*fac
2798 cd          write (iout,'(4i5,4f10.5)')
2799 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2800 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2801 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2802 cd     &      uy(:,j),uz(:,j)
2803 cd          write (iout,'(4f10.5)')
2804 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2805 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2806 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2807 cd           write (iout,'(9f10.5/)')
2808 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2809 C Derivatives of the elements of A in virtual-bond vectors
2810           if (calc_grad) then
2811           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2812           do k=1,3
2813             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2814             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2815             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2816             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2817             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2818             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2819             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2820             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2821             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2822             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2823             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2824             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2825           enddo
2826 C Compute radial contributions to the gradient
2827           facr=-3.0d0*rrmij
2828           a22der=a22*facr
2829           a23der=a23*facr
2830           a32der=a32*facr
2831           a33der=a33*facr
2832           agg(1,1)=a22der*xj
2833           agg(2,1)=a22der*yj
2834           agg(3,1)=a22der*zj
2835           agg(1,2)=a23der*xj
2836           agg(2,2)=a23der*yj
2837           agg(3,2)=a23der*zj
2838           agg(1,3)=a32der*xj
2839           agg(2,3)=a32der*yj
2840           agg(3,3)=a32der*zj
2841           agg(1,4)=a33der*xj
2842           agg(2,4)=a33der*yj
2843           agg(3,4)=a33der*zj
2844 C Add the contributions coming from er
2845           fac3=-3.0d0*fac
2846           do k=1,3
2847             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2848             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2849             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2850             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2851           enddo
2852           do k=1,3
2853 C Derivatives in DC(i)
2854 cgrad            ghalf1=0.5d0*agg(k,1)
2855 cgrad            ghalf2=0.5d0*agg(k,2)
2856 cgrad            ghalf3=0.5d0*agg(k,3)
2857 cgrad            ghalf4=0.5d0*agg(k,4)
2858             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2859      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2860             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2861      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2862             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2863      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2864             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2865      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2866 C Derivatives in DC(i+1)
2867             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2868      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2869             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2870      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2871             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2872      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2873             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2874      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2875 C Derivatives in DC(j)
2876             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2877      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2878             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2879      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2880             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2881      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2882             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2883      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2884 C Derivatives in DC(j+1) or DC(nres-1)
2885             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2886      &      -3.0d0*vryg(k,3)*ury)
2887             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2888      &      -3.0d0*vrzg(k,3)*ury)
2889             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2890      &      -3.0d0*vryg(k,3)*urz)
2891             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2892      &      -3.0d0*vrzg(k,3)*urz)
2893 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2894 cgrad              do l=1,4
2895 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2896 cgrad              enddo
2897 cgrad            endif
2898           enddo
2899           endif ! calc_grad
2900           acipa(1,1)=a22
2901           acipa(1,2)=a23
2902           acipa(2,1)=a32
2903           acipa(2,2)=a33
2904           a22=-a22
2905           a23=-a23
2906           if (calc_grad) then
2907           do l=1,2
2908             do k=1,3
2909               agg(k,l)=-agg(k,l)
2910               aggi(k,l)=-aggi(k,l)
2911               aggi1(k,l)=-aggi1(k,l)
2912               aggj(k,l)=-aggj(k,l)
2913               aggj1(k,l)=-aggj1(k,l)
2914             enddo
2915           enddo
2916           endif ! calc_grad
2917           if (j.lt.nres-1) then
2918             a22=-a22
2919             a32=-a32
2920             do l=1,3,2
2921               do k=1,3
2922                 agg(k,l)=-agg(k,l)
2923                 aggi(k,l)=-aggi(k,l)
2924                 aggi1(k,l)=-aggi1(k,l)
2925                 aggj(k,l)=-aggj(k,l)
2926                 aggj1(k,l)=-aggj1(k,l)
2927               enddo
2928             enddo
2929           else
2930             a22=-a22
2931             a23=-a23
2932             a32=-a32
2933             a33=-a33
2934             do l=1,4
2935               do k=1,3
2936                 agg(k,l)=-agg(k,l)
2937                 aggi(k,l)=-aggi(k,l)
2938                 aggi1(k,l)=-aggi1(k,l)
2939                 aggj(k,l)=-aggj(k,l)
2940                 aggj1(k,l)=-aggj1(k,l)
2941               enddo
2942             enddo
2943           endif
2944           ENDIF ! WCORR
2945           IF (wel_loc.gt.0.0d0) THEN
2946 C Contribution to the local-electrostatic energy coming from the i-j pair
2947           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2948      &     +a33*muij(4)
2949 #ifdef DEBUG
2950           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2951      &     " a33",a33
2952           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2953      &     " wel_loc",wel_loc
2954 #endif
2955           if (shield_mode.eq.0) then
2956            fac_shield(i)=1.0
2957            fac_shield(j)=1.0
2958 C          else
2959 C           fac_shield(i)=0.4
2960 C           fac_shield(j)=0.6
2961           endif
2962           eel_loc_ij=eel_loc_ij
2963      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
2964           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2965      &            'eelloc',i,j,eel_loc_ij
2966 c           if (eel_loc_ij.ne.0)
2967 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2968 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2969
2970           eel_loc=eel_loc+eel_loc_ij
2971 C Now derivative over eel_loc
2972           if (calc_grad) then
2973           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2974      &  (shield_mode.gt.0)) then
2975 C          print *,i,j
2976
2977           do ilist=1,ishield_list(i)
2978            iresshield=shield_list(ilist,i)
2979            do k=1,3
2980            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2981      &                                          /fac_shield(i)
2982 C     &      *2.0
2983            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2984      &              rlocshield
2985      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2986             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2987      &      +rlocshield
2988            enddo
2989           enddo
2990           do ilist=1,ishield_list(j)
2991            iresshield=shield_list(ilist,j)
2992            do k=1,3
2993            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2994      &                                       /fac_shield(j)
2995 C     &     *2.0
2996            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2997      &              rlocshield
2998      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2999            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3000      &             +rlocshield
3001
3002            enddo
3003           enddo
3004
3005           do k=1,3
3006             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3007      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3008             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3009      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3010             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3011      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3012             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3013      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3014            enddo
3015            endif
3016
3017
3018 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3019 c     &                     ' eel_loc_ij',eel_loc_ij
3020 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3021 C Calculate patrial derivative for theta angle
3022 #ifdef NEWCORR
3023          geel_loc_ij=(a22*gmuij1(1)
3024      &     +a23*gmuij1(2)
3025      &     +a32*gmuij1(3)
3026      &     +a33*gmuij1(4))
3027      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3028 c         write(iout,*) "derivative over thatai"
3029 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3030 c     &   a33*gmuij1(4)
3031          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3032      &      geel_loc_ij*wel_loc
3033 c         write(iout,*) "derivative over thatai-1"
3034 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3035 c     &   a33*gmuij2(4)
3036          geel_loc_ij=
3037      &     a22*gmuij2(1)
3038      &     +a23*gmuij2(2)
3039      &     +a32*gmuij2(3)
3040      &     +a33*gmuij2(4)
3041          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3042      &      geel_loc_ij*wel_loc
3043      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3044
3045 c  Derivative over j residue
3046          geel_loc_ji=a22*gmuji1(1)
3047      &     +a23*gmuji1(2)
3048      &     +a32*gmuji1(3)
3049      &     +a33*gmuji1(4)
3050 c         write(iout,*) "derivative over thataj"
3051 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3052 c     &   a33*gmuji1(4)
3053
3054         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3055      &      geel_loc_ji*wel_loc
3056      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3057
3058          geel_loc_ji=
3059      &     +a22*gmuji2(1)
3060      &     +a23*gmuji2(2)
3061      &     +a32*gmuji2(3)
3062      &     +a33*gmuji2(4)
3063 c         write(iout,*) "derivative over thataj-1"
3064 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3065 c     &   a33*gmuji2(4)
3066          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3067      &      geel_loc_ji*wel_loc
3068      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3069 #endif
3070 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3071
3072 C Partial derivatives in virtual-bond dihedral angles gamma
3073           if (i.gt.1)
3074      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3075      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3076      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3077      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3078
3079           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3080      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3081      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3082      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3083 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3084           aux=eel_loc_ij/sss*sssgrad*rmij
3085           ggg(1)=aux*xj
3086           ggg(2)=aux*yj
3087           ggg(3)=aux*zj
3088           do l=1,3
3089             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3090      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3091      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3092             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3093             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3094 cgrad            ghalf=0.5d0*ggg(l)
3095 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3096 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3097           enddo
3098           gel_loc_long(3,j)=gel_loc_long(3,j)+
3099      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
3100
3101           gel_loc_long(3,i)=gel_loc_long(3,i)+
3102      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
3103 cgrad          do k=i+1,j2
3104 cgrad            do l=1,3
3105 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3106 cgrad            enddo
3107 cgrad          enddo
3108 C Remaining derivatives of eello
3109           do l=1,3
3110             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3111      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3112      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3113
3114             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3115      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3116      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3117
3118             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3119      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3120      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3121
3122             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3123      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3124      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
3125
3126           enddo
3127           endif ! calc_grad
3128           ENDIF
3129
3130
3131 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3132 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3133 #ifdef FOURBODY
3134           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3135      &       .and. num_conti.le.maxconts) then
3136 c            write (iout,*) i,j," entered corr"
3137 C
3138 C Calculate the contact function. The ith column of the array JCONT will
3139 C contain the numbers of atoms that make contacts with the atom I (of numbers
3140 C greater than I). The arrays FACONT and GACONT will contain the values of
3141 C the contact function and its derivative.
3142 c           r0ij=1.02D0*rpp(iteli,itelj)
3143 c           r0ij=1.11D0*rpp(iteli,itelj)
3144             r0ij=2.20D0*rpp(iteli,itelj)
3145 c           r0ij=1.55D0*rpp(iteli,itelj)
3146             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3147             if (fcont.gt.0.0D0) then
3148               num_conti=num_conti+1
3149               if (num_conti.gt.maxconts) then
3150                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3151      &                         ' will skip next contacts for this conf.'
3152               else
3153                 jcont_hb(num_conti,i)=j
3154 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3155 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3156                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3157      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3158 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3159 C  terms.
3160                 d_cont(num_conti,i)=rij
3161 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3162 C     --- Electrostatic-interaction matrix ---
3163                 a_chuj(1,1,num_conti,i)=a22
3164                 a_chuj(1,2,num_conti,i)=a23
3165                 a_chuj(2,1,num_conti,i)=a32
3166                 a_chuj(2,2,num_conti,i)=a33
3167 C     --- Gradient of rij
3168                 if (calc_grad) then
3169                 do kkk=1,3
3170                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3171                 enddo
3172                 kkll=0
3173                 do k=1,2
3174                   do l=1,2
3175                     kkll=kkll+1
3176                     do m=1,3
3177                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3178                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3179                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3180                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3181                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3182                     enddo
3183                   enddo
3184                 enddo
3185                 endif ! calc_grad
3186                 ENDIF
3187                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3188 C Calculate contact energies
3189                 cosa4=4.0D0*cosa
3190                 wij=cosa-3.0D0*cosb*cosg
3191                 cosbg1=cosb+cosg
3192                 cosbg2=cosb-cosg
3193 c               fac3=dsqrt(-ael6i)/r0ij**3
3194                 fac3=dsqrt(-ael6i)*r3ij
3195 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3196                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3197                 if (ees0tmp.gt.0) then
3198                   ees0pij=dsqrt(ees0tmp)
3199                 else
3200                   ees0pij=0
3201                 endif
3202 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3203                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3204                 if (ees0tmp.gt.0) then
3205                   ees0mij=dsqrt(ees0tmp)
3206                 else
3207                   ees0mij=0
3208                 endif
3209 c               ees0mij=0.0D0
3210                 if (shield_mode.eq.0) then
3211                 fac_shield(i)=1.0d0
3212                 fac_shield(j)=1.0d0
3213                 else
3214                 ees0plist(num_conti,i)=j
3215 C                fac_shield(i)=0.4d0
3216 C                fac_shield(j)=0.6d0
3217                 endif
3218                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3219      &          *fac_shield(i)*fac_shield(j)
3220                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3221      &          *fac_shield(i)*fac_shield(j)
3222 C Diagnostics. Comment out or remove after debugging!
3223 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3224 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3225 c               ees0m(num_conti,i)=0.0D0
3226 C End diagnostics.
3227 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3228 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3229 C Angular derivatives of the contact function
3230
3231                 ees0pij1=fac3/ees0pij
3232                 ees0mij1=fac3/ees0mij
3233                 fac3p=-3.0D0*fac3*rrmij
3234                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3235                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3236 c               ees0mij1=0.0D0
3237                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3238                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3239                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3240                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3241                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3242                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3243                 ecosap=ecosa1+ecosa2
3244                 ecosbp=ecosb1+ecosb2
3245                 ecosgp=ecosg1+ecosg2
3246                 ecosam=ecosa1-ecosa2
3247                 ecosbm=ecosb1-ecosb2
3248                 ecosgm=ecosg1-ecosg2
3249 C Diagnostics
3250 c               ecosap=ecosa1
3251 c               ecosbp=ecosb1
3252 c               ecosgp=ecosg1
3253 c               ecosam=0.0D0
3254 c               ecosbm=0.0D0
3255 c               ecosgm=0.0D0
3256 C End diagnostics
3257                 facont_hb(num_conti,i)=fcont
3258
3259                 if (calc_grad) then
3260                 fprimcont=fprimcont/rij
3261 cd              facont_hb(num_conti,i)=1.0D0
3262 C Following line is for diagnostics.
3263 cd              fprimcont=0.0D0
3264                 do k=1,3
3265                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3266                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3267                 enddo
3268                 do k=1,3
3269                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3270                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3271                 enddo
3272                 gggp(1)=gggp(1)+ees0pijp*xj
3273      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3274                 gggp(2)=gggp(2)+ees0pijp*yj
3275      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3276                 gggp(3)=gggp(3)+ees0pijp*zj
3277      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3278                 gggm(1)=gggm(1)+ees0mijp*xj
3279      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3280                 gggm(2)=gggm(2)+ees0mijp*yj
3281      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3282                 gggm(3)=gggm(3)+ees0mijp*zj
3283      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3284 C Derivatives due to the contact function
3285                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3286                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3287                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3288                 do k=1,3
3289 c
3290 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3291 c          following the change of gradient-summation algorithm.
3292 c
3293 cgrad                  ghalfp=0.5D0*gggp(k)
3294 cgrad                  ghalfm=0.5D0*gggm(k)
3295                   gacontp_hb1(k,num_conti,i)=!ghalfp
3296      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3297      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3298      &          *fac_shield(i)*fac_shield(j)*sss
3299
3300                   gacontp_hb2(k,num_conti,i)=!ghalfp
3301      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3302      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3303      &          *fac_shield(i)*fac_shield(j)*sss
3304
3305                   gacontp_hb3(k,num_conti,i)=gggp(k)
3306      &          *fac_shield(i)*fac_shield(j)*sss
3307
3308                   gacontm_hb1(k,num_conti,i)=!ghalfm
3309      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3310      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3311      &          *fac_shield(i)*fac_shield(j)*sss
3312
3313                   gacontm_hb2(k,num_conti,i)=!ghalfm
3314      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3315      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3316      &          *fac_shield(i)*fac_shield(j)*sss
3317
3318                   gacontm_hb3(k,num_conti,i)=gggm(k)
3319      &          *fac_shield(i)*fac_shield(j)*sss
3320
3321                 enddo
3322 C Diagnostics. Comment out or remove after debugging!
3323 cdiag           do k=1,3
3324 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3325 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3326 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3327 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3328 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3329 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3330 cdiag           enddo
3331
3332                  endif ! calc_grad
3333
3334               ENDIF ! wcorr
3335               endif  ! num_conti.le.maxconts
3336             endif  ! fcont.gt.0
3337           endif    ! j.gt.i+1
3338 #endif
3339           if (calc_grad) then
3340           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3341             do k=1,4
3342               do l=1,3
3343                 ghalf=0.5d0*agg(l,k)
3344                 aggi(l,k)=aggi(l,k)+ghalf
3345                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3346                 aggj(l,k)=aggj(l,k)+ghalf
3347               enddo
3348             enddo
3349             if (j.eq.nres-1 .and. i.lt.j-2) then
3350               do k=1,4
3351                 do l=1,3
3352                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3353                 enddo
3354               enddo
3355             endif
3356           endif
3357           endif ! calc_grad
3358 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3359       return
3360       end
3361 C-----------------------------------------------------------------------------
3362       subroutine eturn3(i,eello_turn3)
3363 C Third- and fourth-order contributions from turns
3364       implicit real*8 (a-h,o-z)
3365       include 'DIMENSIONS'
3366       include 'DIMENSIONS.ZSCOPT'
3367       include 'COMMON.IOUNITS'
3368       include 'COMMON.GEO'
3369       include 'COMMON.VAR'
3370       include 'COMMON.LOCAL'
3371       include 'COMMON.CHAIN'
3372       include 'COMMON.DERIV'
3373       include 'COMMON.INTERACT'
3374       include 'COMMON.CONTACTS'
3375       include 'COMMON.TORSION'
3376       include 'COMMON.VECTORS'
3377       include 'COMMON.FFIELD'
3378       include 'COMMON.CONTROL'
3379       include 'COMMON.SHIELD'
3380       include 'COMMON.CORRMAT'
3381       dimension ggg(3)
3382       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3383      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3384      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3385      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3386      &  auxgmat2(2,2),auxgmatt2(2,2)
3387       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3388      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3389       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3390      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3391      &    num_conti,j1,j2
3392       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3393       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3394       j=i+2
3395 c      write (iout,*) "eturn3",i,j,j1,j2
3396       a_temp(1,1)=a22
3397       a_temp(1,2)=a23
3398       a_temp(2,1)=a32
3399       a_temp(2,2)=a33
3400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3401 C
3402 C               Third-order contributions
3403 C
3404 C                 (i+2)o----(i+3)
3405 C                      | |
3406 C                      | |
3407 C                 (i+1)o----i
3408 C
3409 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3410 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3411         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3412 c auxalary matices for theta gradient
3413 c auxalary matrix for i+1 and constant i+2
3414         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3415 c auxalary matrix for i+2 and constant i+1
3416         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3417         call transpose2(auxmat(1,1),auxmat1(1,1))
3418         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3419         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3420         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3421         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3422         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3423         if (shield_mode.eq.0) then
3424         fac_shield(i)=1.0
3425         fac_shield(j)=1.0
3426 C        else
3427 C        fac_shield(i)=0.4
3428 C        fac_shield(j)=0.6
3429         endif
3430         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3431      &  *fac_shield(i)*fac_shield(j)*faclipij
3432         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3433      &  *fac_shield(i)*fac_shield(j)
3434         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3435      &    eello_t3
3436         if (calc_grad) then
3437 C#ifdef NEWCORR
3438 C Derivatives in theta
3439         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3440      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3441      &   *fac_shield(i)*fac_shield(j)*faclipij
3442         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3443      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3444      &   *fac_shield(i)*fac_shield(j)*faclipij
3445 C#endif
3446
3447 C Derivatives in shield mode
3448           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3449      &  (shield_mode.gt.0)) then
3450 C          print *,i,j
3451
3452           do ilist=1,ishield_list(i)
3453            iresshield=shield_list(ilist,i)
3454            do k=1,3
3455            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3456 C     &      *2.0
3457            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3458      &              rlocshield
3459      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3460             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3461      &      +rlocshield
3462            enddo
3463           enddo
3464           do ilist=1,ishield_list(j)
3465            iresshield=shield_list(ilist,j)
3466            do k=1,3
3467            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3468 C     &     *2.0
3469            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3470      &              rlocshield
3471      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3472            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3473      &             +rlocshield
3474
3475            enddo
3476           enddo
3477
3478           do k=1,3
3479             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3480      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3481             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3482      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3483             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3484      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3485             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3486      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3487            enddo
3488            endif
3489
3490 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3491 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3492 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3493 cd     &    ' eello_turn3_num',4*eello_turn3_num
3494 C Derivatives in gamma(i)
3495         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3496         call transpose2(auxmat2(1,1),auxmat3(1,1))
3497         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3498         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3499      &   *fac_shield(i)*fac_shield(j)*faclipij
3500 C Derivatives in gamma(i+1)
3501         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3502         call transpose2(auxmat2(1,1),auxmat3(1,1))
3503         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3504         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3505      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3506      &   *fac_shield(i)*fac_shield(j)*faclipij
3507 C Cartesian derivatives
3508         do l=1,3
3509 c            ghalf1=0.5d0*agg(l,1)
3510 c            ghalf2=0.5d0*agg(l,2)
3511 c            ghalf3=0.5d0*agg(l,3)
3512 c            ghalf4=0.5d0*agg(l,4)
3513           a_temp(1,1)=aggi(l,1)!+ghalf1
3514           a_temp(1,2)=aggi(l,2)!+ghalf2
3515           a_temp(2,1)=aggi(l,3)!+ghalf3
3516           a_temp(2,2)=aggi(l,4)!+ghalf4
3517           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3518           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3519      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3520      &   *fac_shield(i)*fac_shield(j)*faclipij
3521
3522           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3523           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3524           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3525           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3526           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3527           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3528      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3529      &   *fac_shield(i)*fac_shield(j)*faclipij
3530           a_temp(1,1)=aggj(l,1)!+ghalf1
3531           a_temp(1,2)=aggj(l,2)!+ghalf2
3532           a_temp(2,1)=aggj(l,3)!+ghalf3
3533           a_temp(2,2)=aggj(l,4)!+ghalf4
3534           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3535           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3536      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3537      &   *fac_shield(i)*fac_shield(j)*faclipij
3538           a_temp(1,1)=aggj1(l,1)
3539           a_temp(1,2)=aggj1(l,2)
3540           a_temp(2,1)=aggj1(l,3)
3541           a_temp(2,2)=aggj1(l,4)
3542           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3543           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3544      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3545      &   *fac_shield(i)*fac_shield(j)*faclipij
3546         enddo
3547
3548         endif ! calc_grad
3549
3550       return
3551       end
3552 C-------------------------------------------------------------------------------
3553       subroutine eturn4(i,eello_turn4)
3554 C Third- and fourth-order contributions from turns
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'DIMENSIONS.ZSCOPT'
3558       include 'COMMON.IOUNITS'
3559       include 'COMMON.GEO'
3560       include 'COMMON.VAR'
3561       include 'COMMON.LOCAL'
3562       include 'COMMON.CHAIN'
3563       include 'COMMON.DERIV'
3564       include 'COMMON.INTERACT'
3565       include 'COMMON.CONTACTS'
3566       include 'COMMON.TORSION'
3567       include 'COMMON.VECTORS'
3568       include 'COMMON.FFIELD'
3569       include 'COMMON.CONTROL'
3570       include 'COMMON.SHIELD'
3571       include 'COMMON.CORRMAT'
3572       dimension ggg(3)
3573       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3574      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3575      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3576      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3577      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3578      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3579      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3580       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3581      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3582       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3583      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3584      &    num_conti,j1,j2
3585       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3586       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3587       j=i+3
3588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3589 C
3590 C               Fourth-order contributions
3591 C
3592 C                 (i+3)o----(i+4)
3593 C                     /  |
3594 C               (i+2)o   |
3595 C                     \  |
3596 C                 (i+1)o----i
3597 C
3598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3599 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3600 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3601 c        write(iout,*)"WCHODZE W PROGRAM"
3602         a_temp(1,1)=a22
3603         a_temp(1,2)=a23
3604         a_temp(2,1)=a32
3605         a_temp(2,2)=a33
3606         iti1=itype2loc(itype(i+1))
3607         iti2=itype2loc(itype(i+2))
3608         iti3=itype2loc(itype(i+3))
3609 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3610         call transpose2(EUg(1,1,i+1),e1t(1,1))
3611         call transpose2(Eug(1,1,i+2),e2t(1,1))
3612         call transpose2(Eug(1,1,i+3),e3t(1,1))
3613 C Ematrix derivative in theta
3614         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3615         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3616         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3617         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3618 c       eta1 in derivative theta
3619         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3620         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3621 c       auxgvec is derivative of Ub2 so i+3 theta
3622         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3623 c       auxalary matrix of E i+1
3624         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3625 c        s1=0.0
3626 c        gs1=0.0
3627         s1=scalar2(b1(1,i+2),auxvec(1))
3628 c derivative of theta i+2 with constant i+3
3629         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3630 c derivative of theta i+2 with constant i+2
3631         gs32=scalar2(b1(1,i+2),auxgvec(1))
3632 c derivative of E matix in theta of i+1
3633         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3634
3635         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3636 c       ea31 in derivative theta
3637         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3638         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3639 c auxilary matrix auxgvec of Ub2 with constant E matirx
3640         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3641 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3642         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3643
3644 c        s2=0.0
3645 c        gs2=0.0
3646         s2=scalar2(b1(1,i+1),auxvec(1))
3647 c derivative of theta i+1 with constant i+3
3648         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3649 c derivative of theta i+2 with constant i+1
3650         gs21=scalar2(b1(1,i+1),auxgvec(1))
3651 c derivative of theta i+3 with constant i+1
3652         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3653 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3654 c     &  gtb1(1,i+1)
3655         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3656 c two derivatives over diffetent matrices
3657 c gtae3e2 is derivative over i+3
3658         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3659 c ae3gte2 is derivative over i+2
3660         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3661         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3662 c three possible derivative over theta E matices
3663 c i+1
3664         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3665 c i+2
3666         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3667 c i+3
3668         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3669         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3670
3671         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3672         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3673         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3674         if (shield_mode.eq.0) then
3675         fac_shield(i)=1.0
3676         fac_shield(j)=1.0
3677 C        else
3678 C        fac_shield(i)=0.6
3679 C        fac_shield(j)=0.4
3680         endif
3681         eello_turn4=eello_turn4-(s1+s2+s3)
3682      &  *fac_shield(i)*fac_shield(j)*faclipij
3683         eello_t4=-(s1+s2+s3)
3684      &  *fac_shield(i)*fac_shield(j)
3685 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3686         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3687      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3688 C Now derivative over shield:
3689           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3690      &  (shield_mode.gt.0)) then
3691 C          print *,i,j
3692
3693           do ilist=1,ishield_list(i)
3694            iresshield=shield_list(ilist,i)
3695            do k=1,3
3696            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3697 C     &      *2.0
3698            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3699      &              rlocshield
3700      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3701             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3702      &      +rlocshield
3703            enddo
3704           enddo
3705           do ilist=1,ishield_list(j)
3706            iresshield=shield_list(ilist,j)
3707            do k=1,3
3708            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3709 C     &     *2.0
3710            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3711      &              rlocshield
3712      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3713            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3714      &             +rlocshield
3715
3716            enddo
3717           enddo
3718
3719           do k=1,3
3720             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3721      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3722             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3723      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3724             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3725      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3726             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3727      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3728            enddo
3729            endif
3730 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3731 cd     &    ' eello_turn4_num',8*eello_turn4_num
3732 #ifdef NEWCORR
3733         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3734      &                  -(gs13+gsE13+gsEE1)*wturn4
3735      &  *fac_shield(i)*fac_shield(j)
3736         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3737      &                    -(gs23+gs21+gsEE2)*wturn4
3738      &  *fac_shield(i)*fac_shield(j)
3739
3740         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3741      &                    -(gs32+gsE31+gsEE3)*wturn4
3742      &  *fac_shield(i)*fac_shield(j)
3743
3744 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3745 c     &   gs2
3746 #endif
3747         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3748      &      'eturn4',i,j,-(s1+s2+s3)
3749 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3750 c     &    ' eello_turn4_num',8*eello_turn4_num
3751 C Derivatives in gamma(i)
3752         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3753         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3754         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3755         s1=scalar2(b1(1,i+2),auxvec(1))
3756         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3757         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3758         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3759      &  *fac_shield(i)*fac_shield(j)*faclipij
3760 C Derivatives in gamma(i+1)
3761         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3762         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3763         s2=scalar2(b1(1,i+1),auxvec(1))
3764         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3765         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3766         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3767         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3768      &  *fac_shield(i)*fac_shield(j)*faclipij
3769 C Derivatives in gamma(i+2)
3770         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3771         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3772         s1=scalar2(b1(1,i+2),auxvec(1))
3773         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3774         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3775         s2=scalar2(b1(1,i+1),auxvec(1))
3776         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3777         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3778         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3779         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3780      &  *fac_shield(i)*fac_shield(j)*faclipij
3781         if (calc_grad) then
3782 C Cartesian derivatives
3783 C Derivatives of this turn contributions in DC(i+2)
3784         if (j.lt.nres-1) then
3785           do l=1,3
3786             a_temp(1,1)=agg(l,1)
3787             a_temp(1,2)=agg(l,2)
3788             a_temp(2,1)=agg(l,3)
3789             a_temp(2,2)=agg(l,4)
3790             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3791             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3792             s1=scalar2(b1(1,i+2),auxvec(1))
3793             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3794             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3795             s2=scalar2(b1(1,i+1),auxvec(1))
3796             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3797             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3798             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3799             ggg(l)=-(s1+s2+s3)
3800             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3801      &  *fac_shield(i)*fac_shield(j)*faclipij
3802           enddo
3803         endif
3804 C Remaining derivatives of this turn contribution
3805         do l=1,3
3806           a_temp(1,1)=aggi(l,1)
3807           a_temp(1,2)=aggi(l,2)
3808           a_temp(2,1)=aggi(l,3)
3809           a_temp(2,2)=aggi(l,4)
3810           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3812           s1=scalar2(b1(1,i+2),auxvec(1))
3813           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3814           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3815           s2=scalar2(b1(1,i+1),auxvec(1))
3816           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3817           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3818           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3819           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3820      &  *fac_shield(i)*fac_shield(j)*faclipij
3821           a_temp(1,1)=aggi1(l,1)
3822           a_temp(1,2)=aggi1(l,2)
3823           a_temp(2,1)=aggi1(l,3)
3824           a_temp(2,2)=aggi1(l,4)
3825           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3826           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3827           s1=scalar2(b1(1,i+2),auxvec(1))
3828           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3829           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3830           s2=scalar2(b1(1,i+1),auxvec(1))
3831           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3832           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3833           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3834           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3835      &  *fac_shield(i)*fac_shield(j)*faclipij
3836           a_temp(1,1)=aggj(l,1)
3837           a_temp(1,2)=aggj(l,2)
3838           a_temp(2,1)=aggj(l,3)
3839           a_temp(2,2)=aggj(l,4)
3840           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3841           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3842           s1=scalar2(b1(1,i+2),auxvec(1))
3843           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3844           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3845           s2=scalar2(b1(1,i+1),auxvec(1))
3846           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3847           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3848           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3849           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3850      &  *fac_shield(i)*fac_shield(j)*faclipij
3851           a_temp(1,1)=aggj1(l,1)
3852           a_temp(1,2)=aggj1(l,2)
3853           a_temp(2,1)=aggj1(l,3)
3854           a_temp(2,2)=aggj1(l,4)
3855           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3856           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3857           s1=scalar2(b1(1,i+2),auxvec(1))
3858           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3859           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3860           s2=scalar2(b1(1,i+1),auxvec(1))
3861           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3862           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3863           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3864 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3865           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3866      &  *fac_shield(i)*fac_shield(j)*faclipij
3867         enddo
3868
3869         endif ! calc_grad
3870
3871       return
3872       end
3873 C-----------------------------------------------------------------------------
3874       subroutine vecpr(u,v,w)
3875       implicit real*8(a-h,o-z)
3876       dimension u(3),v(3),w(3)
3877       w(1)=u(2)*v(3)-u(3)*v(2)
3878       w(2)=-u(1)*v(3)+u(3)*v(1)
3879       w(3)=u(1)*v(2)-u(2)*v(1)
3880       return
3881       end
3882 C-----------------------------------------------------------------------------
3883       subroutine unormderiv(u,ugrad,unorm,ungrad)
3884 C This subroutine computes the derivatives of a normalized vector u, given
3885 C the derivatives computed without normalization conditions, ugrad. Returns
3886 C ungrad.
3887       implicit none
3888       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3889       double precision vec(3)
3890       double precision scalar
3891       integer i,j
3892 c      write (2,*) 'ugrad',ugrad
3893 c      write (2,*) 'u',u
3894       do i=1,3
3895         vec(i)=scalar(ugrad(1,i),u(1))
3896       enddo
3897 c      write (2,*) 'vec',vec
3898       do i=1,3
3899         do j=1,3
3900           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3901         enddo
3902       enddo
3903 c      write (2,*) 'ungrad',ungrad
3904       return
3905       end
3906 C-----------------------------------------------------------------------------
3907       subroutine escp(evdw2,evdw2_14)
3908 C
3909 C This subroutine calculates the excluded-volume interaction energy between
3910 C peptide-group centers and side chains and its gradient in virtual-bond and
3911 C side-chain vectors.
3912 C
3913       implicit real*8 (a-h,o-z)
3914       include 'DIMENSIONS'
3915       include 'DIMENSIONS.ZSCOPT'
3916       include 'COMMON.CONTROL'
3917       include 'COMMON.GEO'
3918       include 'COMMON.VAR'
3919       include 'COMMON.LOCAL'
3920       include 'COMMON.CHAIN'
3921       include 'COMMON.DERIV'
3922       include 'COMMON.INTERACT'
3923       include 'COMMON.FFIELD'
3924       include 'COMMON.IOUNITS'
3925       dimension ggg(3)
3926       evdw2=0.0D0
3927       evdw2_14=0.0d0
3928 cd    print '(a)','Enter ESCP'
3929 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3930 c     &  ' scal14',scal14
3931       do i=iatscp_s,iatscp_e
3932         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3933         iteli=itel(i)
3934 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3935 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3936         if (iteli.eq.0) goto 1225
3937         xi=0.5D0*(c(1,i)+c(1,i+1))
3938         yi=0.5D0*(c(2,i)+c(2,i+1))
3939         zi=0.5D0*(c(3,i)+c(3,i+1))
3940         call to_box(xi,yi,zi)
3941         do iint=1,nscp_gr(i)
3942
3943         do j=iscpstart(i,iint),iscpend(i,iint)
3944           itypj=iabs(itype(j))
3945           if (itypj.eq.ntyp1) cycle
3946 C Uncomment following three lines for SC-p interactions
3947 c         xj=c(1,nres+j)-xi
3948 c         yj=c(2,nres+j)-yi
3949 c         zj=c(3,nres+j)-zi
3950 C Uncomment following three lines for Ca-p interactions
3951           xj=c(1,j)
3952           yj=c(2,j)
3953           zj=c(3,j)
3954 C returning the jth atom to box
3955           call to_box(xj,yj,zj)
3956           xj=boxshift(xj-xi,boxxsize)
3957           yj=boxshift(yj-yi,boxysize)
3958           zj=boxshift(zj-zi,boxzsize)
3959           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3960 C sss is scaling function for smoothing the cutoff gradient otherwise
3961 C the gradient would not be continuouse
3962           sss=sscale(1.0d0/(dsqrt(rrij)))
3963           if (sss.le.0.0d0) cycle
3964           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3965           fac=rrij**expon2
3966           e1=fac*fac*aad(itypj,iteli)
3967           e2=fac*bad(itypj,iteli)
3968           if (iabs(j-i) .le. 2) then
3969             e1=scal14*e1
3970             e2=scal14*e2
3971             evdw2_14=evdw2_14+(e1+e2)*sss
3972           endif
3973           evdwij=e1+e2
3974 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3975 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3976 c     &       bad(itypj,iteli)
3977           evdw2=evdw2+evdwij*sss
3978           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3979      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3980      &       bad(itypj,iteli)
3981
3982           if (calc_grad) then
3983 C
3984 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3985 C
3986           fac=-(evdwij+e1)*rrij*sss
3987           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3988           ggg(1)=xj*fac
3989           ggg(2)=yj*fac
3990           ggg(3)=zj*fac
3991           if (j.lt.i) then
3992 cd          write (iout,*) 'j<i'
3993 C Uncomment following three lines for SC-p interactions
3994 c           do k=1,3
3995 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3996 c           enddo
3997           else
3998 cd          write (iout,*) 'j>i'
3999             do k=1,3
4000               ggg(k)=-ggg(k)
4001 C Uncomment following line for SC-p interactions
4002 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4003             enddo
4004           endif
4005           do k=1,3
4006             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4007           enddo
4008           kstart=min0(i+1,j)
4009           kend=max0(i-1,j-1)
4010 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4011 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4012           do k=kstart,kend
4013             do l=1,3
4014               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4015             enddo
4016           enddo
4017           endif ! calc_grad
4018         enddo
4019         enddo ! iint
4020  1225   continue
4021       enddo ! i
4022       do i=1,nct
4023         do j=1,3
4024           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4025           gradx_scp(j,i)=expon*gradx_scp(j,i)
4026         enddo
4027       enddo
4028 C******************************************************************************
4029 C
4030 C                              N O T E !!!
4031 C
4032 C To save time the factor EXPON has been extracted from ALL components
4033 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4034 C use!
4035 C
4036 C******************************************************************************
4037       return
4038       end
4039 C--------------------------------------------------------------------------
4040       subroutine edis(ehpb)
4041 C
4042 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4043 C
4044       implicit real*8 (a-h,o-z)
4045       include 'DIMENSIONS'
4046       include 'DIMENSIONS.ZSCOPT'
4047       include 'COMMON.SBRIDGE'
4048       include 'COMMON.CHAIN'
4049       include 'COMMON.DERIV'
4050       include 'COMMON.VAR'
4051       include 'COMMON.INTERACT'
4052       include 'COMMON.CONTROL'
4053       include 'COMMON.IOUNITS'
4054       dimension ggg(3),ggg_peak(3,1000)
4055       ehpb=0.0D0
4056       do i=1,3
4057        ggg(i)=0.0d0
4058       enddo
4059 c 8/21/18 AL: added explicit restraints on reference coords
4060 c      write (iout,*) "restr_on_coord",restr_on_coord
4061       if (restr_on_coord) then
4062
4063       do i=nnt,nct
4064         ecoor=0.0d0
4065         if (itype(i).eq.ntyp1) cycle
4066         do j=1,3
4067           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4068           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4069         enddo
4070         if (itype(i).ne.10) then
4071           do j=1,3
4072             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4073             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4074           enddo
4075         endif
4076         if (energy_dec) write (iout,*)
4077      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4078         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4079       enddo
4080
4081       endif
4082
4083 C      write (iout,*) ,"link_end",link_end,constr_dist
4084 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4085 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4086 c     &  " constr_dist",constr_dist
4087       if (link_end.eq.0.and.link_end_peak.eq.0) return
4088       do i=link_start_peak,link_end_peak
4089         ehpb_peak=0.0d0
4090 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4091 c     &   ipeak(1,i),ipeak(2,i)
4092         do ip=ipeak(1,i),ipeak(2,i)
4093           ii=ihpb_peak(ip)
4094           jj=jhpb_peak(ip)
4095           dd=dist(ii,jj)
4096           iip=ip-ipeak(1,i)+1
4097 C iii and jjj point to the residues for which the distance is assigned.
4098 c          if (ii.gt.nres) then
4099 c            iii=ii-nres
4100 c            jjj=jj-nres
4101 c          else
4102 c            iii=ii
4103 c            jjj=jj
4104 c          endif
4105           if (ii.gt.nres) then
4106             iii=ii-nres
4107           else
4108             iii=ii
4109           endif
4110           if (jj.gt.nres) then
4111             jjj=jj-nres
4112           else
4113             jjj=jj
4114           endif
4115           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4116           aux=dexp(-scal_peak*aux)
4117           ehpb_peak=ehpb_peak+aux
4118           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4119      &      forcon_peak(ip))*aux/dd
4120           do j=1,3
4121             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4122           enddo
4123           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4124      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4125      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4126         enddo
4127 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4128         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4129         do ip=ipeak(1,i),ipeak(2,i)
4130           iip=ip-ipeak(1,i)+1
4131           do j=1,3
4132             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4133           enddo
4134           ii=ihpb_peak(ip)
4135           jj=jhpb_peak(ip)
4136 C iii and jjj point to the residues for which the distance is assigned.
4137           if (ii.gt.nres) then
4138             iii=ii-nres
4139             jjj=jj-nres
4140           else
4141             iii=ii
4142             jjj=jj
4143           endif
4144           if (iii.lt.ii) then
4145             do j=1,3
4146               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4147             enddo
4148           endif
4149           if (jjj.lt.jj) then
4150             do j=1,3
4151               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4152             enddo
4153           endif
4154           do k=1,3
4155             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4156             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4157           enddo
4158         enddo
4159       enddo
4160       do i=link_start,link_end
4161 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4162 C CA-CA distance used in regularization of structure.
4163         ii=ihpb(i)
4164         jj=jhpb(i)
4165 C iii and jjj point to the residues for which the distance is assigned.
4166         if (ii.gt.nres) then
4167           iii=ii-nres
4168         else
4169           iii=ii
4170         endif
4171         if (jj.gt.nres) then
4172           jjj=jj-nres
4173         else
4174           jjj=jj
4175         endif
4176 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4177 c     &    dhpb(i),dhpb1(i),forcon(i)
4178 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4179 C    distance and angle dependent SS bond potential.
4180 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4181 C     & iabs(itype(jjj)).eq.1) then
4182 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4183 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4184         if (.not.dyn_ss .and. i.le.nss) then
4185 C 15/02/13 CC dynamic SSbond - additional check
4186           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4187      &        iabs(itype(jjj)).eq.1) then
4188            call ssbond_ene(iii,jjj,eij)
4189            ehpb=ehpb+2*eij
4190          endif
4191 cd          write (iout,*) "eij",eij
4192 cd   &   ' waga=',waga,' fac=',fac
4193 !        else if (ii.gt.nres .and. jj.gt.nres) then
4194         else
4195 C Calculate the distance between the two points and its difference from the
4196 C target distance.
4197           dd=dist(ii,jj)
4198           if (irestr_type(i).eq.11) then
4199             ehpb=ehpb+fordepth(i)!**4.0d0
4200      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4201             fac=fordepth(i)!**4.0d0
4202      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4203             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4204      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4205      &        ehpb,irestr_type(i)
4206           else if (irestr_type(i).eq.10) then
4207 c AL 6//19/2018 cross-link restraints
4208             xdis = 0.5d0*(dd/forcon(i))**2
4209             expdis = dexp(-xdis)
4210 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4211             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4212 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4213 c     &          " wboltzd",wboltzd
4214             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4215 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4216             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4217      &           *expdis/(aux*forcon(i)**2)
4218             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4219      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4220      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4221           else if (irestr_type(i).eq.2) then
4222 c Quartic restraints
4223             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4224             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4225      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4226      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4227             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4228           else
4229 c Quadratic restraints
4230             rdis=dd-dhpb(i)
4231 C Get the force constant corresponding to this distance.
4232             waga=forcon(i)
4233 C Calculate the contribution to energy.
4234             ehpb=ehpb+0.5d0*waga*rdis*rdis
4235             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4236      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4237      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4238 C
4239 C Evaluate gradient.
4240 C
4241             fac=waga*rdis/dd
4242           endif
4243 c Calculate Cartesian gradient
4244           do j=1,3
4245             ggg(j)=fac*(c(j,jj)-c(j,ii))
4246           enddo
4247 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4248 C If this is a SC-SC distance, we need to calculate the contributions to the
4249 C Cartesian gradient in the SC vectors (ghpbx).
4250           if (iii.lt.ii) then
4251             do j=1,3
4252               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4253             enddo
4254           endif
4255           if (jjj.lt.jj) then
4256             do j=1,3
4257               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4258             enddo
4259           endif
4260           do k=1,3
4261             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4262             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4263           enddo
4264         endif
4265       enddo
4266       return
4267       end
4268 C--------------------------------------------------------------------------
4269       subroutine ssbond_ene(i,j,eij)
4270 C
4271 C Calculate the distance and angle dependent SS-bond potential energy
4272 C using a free-energy function derived based on RHF/6-31G** ab initio
4273 C calculations of diethyl disulfide.
4274 C
4275 C A. Liwo and U. Kozlowska, 11/24/03
4276 C
4277       implicit real*8 (a-h,o-z)
4278       include 'DIMENSIONS'
4279       include 'DIMENSIONS.ZSCOPT'
4280       include 'COMMON.SBRIDGE'
4281       include 'COMMON.CHAIN'
4282       include 'COMMON.DERIV'
4283       include 'COMMON.LOCAL'
4284       include 'COMMON.INTERACT'
4285       include 'COMMON.VAR'
4286       include 'COMMON.IOUNITS'
4287       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4288       itypi=iabs(itype(i))
4289       xi=c(1,nres+i)
4290       yi=c(2,nres+i)
4291       zi=c(3,nres+i)
4292       dxi=dc_norm(1,nres+i)
4293       dyi=dc_norm(2,nres+i)
4294       dzi=dc_norm(3,nres+i)
4295       dsci_inv=dsc_inv(itypi)
4296       itypj=iabs(itype(j))
4297       dscj_inv=dsc_inv(itypj)
4298       xj=c(1,nres+j)-xi
4299       yj=c(2,nres+j)-yi
4300       zj=c(3,nres+j)-zi
4301       dxj=dc_norm(1,nres+j)
4302       dyj=dc_norm(2,nres+j)
4303       dzj=dc_norm(3,nres+j)
4304       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4305       rij=dsqrt(rrij)
4306       erij(1)=xj*rij
4307       erij(2)=yj*rij
4308       erij(3)=zj*rij
4309       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4310       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4311       om12=dxi*dxj+dyi*dyj+dzi*dzj
4312       do k=1,3
4313         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4314         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4315       enddo
4316       rij=1.0d0/rij
4317       deltad=rij-d0cm
4318       deltat1=1.0d0-om1
4319       deltat2=1.0d0+om2
4320       deltat12=om2-om1+2.0d0
4321       cosphi=om12-om1*om2
4322       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4323      &  +akct*deltad*deltat12
4324      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4325 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4326 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4327 c     &  " deltat12",deltat12," eij",eij
4328       ed=2*akcm*deltad+akct*deltat12
4329       pom1=akct*deltad
4330       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4331       eom1=-2*akth*deltat1-pom1-om2*pom2
4332       eom2= 2*akth*deltat2+pom1-om1*pom2
4333       eom12=pom2
4334       do k=1,3
4335         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4336       enddo
4337       do k=1,3
4338         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4339      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4340         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4341      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4342       enddo
4343 C
4344 C Calculate the components of the gradient in DC and X
4345 C
4346       do k=i,j-1
4347         do l=1,3
4348           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4349         enddo
4350       enddo
4351       return
4352       end
4353 C--------------------------------------------------------------------------
4354 c MODELLER restraint function
4355       subroutine e_modeller(ehomology_constr)
4356       implicit real*8 (a-h,o-z)
4357       include 'DIMENSIONS'
4358       include 'DIMENSIONS.ZSCOPT'
4359       include 'DIMENSIONS.FREE'
4360       integer nnn, i, j, k, ki, irec, l
4361       integer katy, odleglosci, test7
4362       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
4363       real*8 distance(max_template),distancek(max_template),
4364      &    min_odl,godl(max_template),dih_diff(max_template)
4365
4366 c
4367 c     FP - 30/10/2014 Temporary specifications for homology restraints
4368 c
4369       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
4370      &                 sgtheta
4371       double precision, dimension (maxres) :: guscdiff,usc_diff
4372       double precision, dimension (max_template) ::
4373      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4374      &           theta_diff
4375
4376       include 'COMMON.SBRIDGE'
4377       include 'COMMON.CHAIN'
4378       include 'COMMON.GEO'
4379       include 'COMMON.DERIV'
4380       include 'COMMON.LOCAL'
4381       include 'COMMON.INTERACT'
4382       include 'COMMON.VAR'
4383       include 'COMMON.IOUNITS'
4384       include 'COMMON.CONTROL'
4385       include 'COMMON.HOMRESTR'
4386       include 'COMMON.HOMOLOGY'
4387       include 'COMMON.SETUP'
4388       include 'COMMON.NAMES'
4389
4390       do i=1,max_template
4391         distancek(i)=9999999.9
4392       enddo
4393
4394       odleg=0.0d0
4395
4396 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4397 c function)
4398 C AL 5/2/14 - Introduce list of restraints
4399 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4400 #ifdef DEBUG
4401       write(iout,*) "------- dist restrs start -------"
4402 #endif
4403       do ii = link_start_homo,link_end_homo
4404          i = ires_homo(ii)
4405          j = jres_homo(ii)
4406          dij=dist(i,j)
4407 c        write (iout,*) "dij(",i,j,") =",dij
4408          nexl=0
4409          do k=1,constr_homology
4410            if(.not.l_homo(k,ii)) then
4411               nexl=nexl+1
4412               cycle
4413            endif
4414            distance(k)=odl(k,ii)-dij
4415 c          write (iout,*) "distance(",k,") =",distance(k)
4416 c
4417 c          For Gaussian-type Urestr
4418 c
4419            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4420 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4421 c          write (iout,*) "distancek(",k,") =",distancek(k)
4422 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4423 c
4424 c          For Lorentzian-type Urestr
4425 c
4426            if (waga_dist.lt.0.0d0) then
4427               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4428               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4429      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4430            endif
4431          enddo
4432
4433 c         min_odl=minval(distancek)
4434          if (nexl.gt.0) then
4435            min_odl=0.0d0
4436          else
4437            do kk=1,constr_homology
4438             if(l_homo(kk,ii)) then
4439               min_odl=distancek(kk)
4440               exit
4441             endif
4442            enddo
4443            do kk=1,constr_homology
4444             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4445      &              min_odl=distancek(kk)
4446            enddo
4447          endif
4448 c        write (iout,* )"min_odl",min_odl
4449 #ifdef DEBUG
4450          write (iout,*) "ij dij",i,j,dij
4451          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4452          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4453          write (iout,* )"min_odl",min_odl
4454 #endif
4455 #ifdef OLDRESTR
4456          odleg2=0.0d0
4457 #else
4458          if (waga_dist.ge.0.0d0) then
4459            odleg2=nexl
4460          else
4461            odleg2=0.0d0
4462          endif
4463 #endif
4464          do k=1,constr_homology
4465 c Nie wiem po co to liczycie jeszcze raz!
4466 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4467 c     &              (2*(sigma_odl(i,j,k))**2))
4468            if(.not.l_homo(k,ii)) cycle
4469            if (waga_dist.ge.0.0d0) then
4470 c
4471 c          For Gaussian-type Urestr
4472 c
4473             godl(k)=dexp(-distancek(k)+min_odl)
4474             odleg2=odleg2+godl(k)
4475 c
4476 c          For Lorentzian-type Urestr
4477 c
4478            else
4479             odleg2=odleg2+distancek(k)
4480            endif
4481
4482 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4483 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4484 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4485 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4486
4487          enddo
4488 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4489 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4490 #ifdef DEBUG
4491          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4492          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4493 #endif
4494            if (waga_dist.ge.0.0d0) then
4495 c
4496 c          For Gaussian-type Urestr
4497 c
4498               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4499 c
4500 c          For Lorentzian-type Urestr
4501 c
4502            else
4503               odleg=odleg+odleg2/constr_homology
4504            endif
4505 c
4506 #ifdef GRAD
4507 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4508 c Gradient
4509 c
4510 c          For Gaussian-type Urestr
4511 c
4512          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4513          sum_sgodl=0.0d0
4514          do k=1,constr_homology
4515 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4516 c     &           *waga_dist)+min_odl
4517 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4518 c
4519          if(.not.l_homo(k,ii)) cycle
4520          if (waga_dist.ge.0.0d0) then
4521 c          For Gaussian-type Urestr
4522 c
4523            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4524 c
4525 c          For Lorentzian-type Urestr
4526 c
4527          else
4528            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4529      &           sigma_odlir(k,ii)**2)**2)
4530          endif
4531            sum_sgodl=sum_sgodl+sgodl
4532
4533 c            sgodl2=sgodl2+sgodl
4534 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4535 c      write(iout,*) "constr_homology=",constr_homology
4536 c      write(iout,*) i, j, k, "TEST K"
4537          enddo
4538          if (waga_dist.ge.0.0d0) then
4539 c
4540 c          For Gaussian-type Urestr
4541 c
4542             grad_odl3=waga_homology(iset)*waga_dist
4543      &                *sum_sgodl/(sum_godl*dij)
4544 c
4545 c          For Lorentzian-type Urestr
4546 c
4547          else
4548 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4549 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4550             grad_odl3=-waga_homology(iset)*waga_dist*
4551      &                sum_sgodl/(constr_homology*dij)
4552          endif
4553 c
4554 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4555
4556
4557 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4558 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4559 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4560
4561 ccc      write(iout,*) godl, sgodl, grad_odl3
4562
4563 c          grad_odl=grad_odl+grad_odl3
4564
4565          do jik=1,3
4566             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4567 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4568 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4569 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4570             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4571             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4572 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4573 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4574 c         if (i.eq.25.and.j.eq.27) then
4575 c         write(iout,*) "jik",jik,"i",i,"j",j
4576 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4577 c         write(iout,*) "grad_odl3",grad_odl3
4578 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4579 c         write(iout,*) "ggodl",ggodl
4580 c         write(iout,*) "ghpbc(",jik,i,")",
4581 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4582 c     &                 ghpbc(jik,j)
4583 c         endif
4584          enddo
4585 #endif
4586 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4587 ccc     & dLOG(odleg2),"-odleg=", -odleg
4588
4589       enddo ! ii-loop for dist
4590 #ifdef DEBUG
4591       write(iout,*) "------- dist restrs end -------"
4592 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4593 c    &     waga_d.eq.1.0d0) call sum_gradient
4594 #endif
4595 c Pseudo-energy and gradient from dihedral-angle restraints from
4596 c homology templates
4597 c      write (iout,*) "End of distance loop"
4598 c      call flush(iout)
4599       kat=0.0d0
4600 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4601 #ifdef DEBUG
4602       write(iout,*) "------- dih restrs start -------"
4603       do i=idihconstr_start_homo,idihconstr_end_homo
4604         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4605       enddo
4606 #endif
4607       do i=idihconstr_start_homo,idihconstr_end_homo
4608         kat2=0.0d0
4609 c        betai=beta(i,i+1,i+2,i+3)
4610         betai = phi(i)
4611 c       write (iout,*) "betai =",betai
4612         do k=1,constr_homology
4613           dih_diff(k)=pinorm(dih(k,i)-betai)
4614 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4615 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4616 c     &                                   -(6.28318-dih_diff(i,k))
4617 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4618 c     &                                   6.28318+dih_diff(i,k)
4619 #ifdef OLD_DIHED
4620           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4621 #else
4622           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4623 #endif
4624 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4625           gdih(k)=dexp(kat3)
4626           kat2=kat2+gdih(k)
4627 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4628 c          write(*,*)""
4629         enddo
4630 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4631 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4632 #ifdef DEBUG
4633         write (iout,*) "i",i," betai",betai," kat2",kat2
4634         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4635 #endif
4636         if (kat2.le.1.0d-14) cycle
4637         kat=kat-dLOG(kat2/constr_homology)
4638 c       write (iout,*) "kat",kat ! sum of -ln-s
4639
4640 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4641 ccc     & dLOG(kat2), "-kat=", -kat
4642
4643 #ifdef GRAD
4644 c ----------------------------------------------------------------------
4645 c Gradient
4646 c ----------------------------------------------------------------------
4647
4648         sum_gdih=kat2
4649         sum_sgdih=0.0d0
4650         do k=1,constr_homology
4651 #ifdef OLD_DIHED
4652           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4653 #else
4654           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4655 #endif
4656 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4657           sum_sgdih=sum_sgdih+sgdih
4658         enddo
4659 c       grad_dih3=sum_sgdih/sum_gdih
4660         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4661
4662 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4663 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4664 ccc     & gloc(nphi+i-3,icg)
4665         gloc(i,icg)=gloc(i,icg)+grad_dih3
4666 c        if (i.eq.25) then
4667 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4668 c        endif
4669 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4670 ccc     & gloc(nphi+i-3,icg)
4671 #endif
4672       enddo ! i-loop for dih
4673 #ifdef DEBUG
4674       write(iout,*) "------- dih restrs end -------"
4675 #endif
4676
4677 c Pseudo-energy and gradient for theta angle restraints from
4678 c homology templates
4679 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4680 c adapted
4681
4682 c
4683 c     For constr_homology reference structures (FP)
4684 c
4685 c     Uconst_back_tot=0.0d0
4686       Eval=0.0d0
4687       Erot=0.0d0
4688 c     Econstr_back legacy
4689 #ifdef GRAD
4690       do i=1,nres
4691 c     do i=ithet_start,ithet_end
4692        dutheta(i)=0.0d0
4693 c     enddo
4694 c     do i=loc_start,loc_end
4695         do j=1,3
4696           duscdiff(j,i)=0.0d0
4697           duscdiffx(j,i)=0.0d0
4698         enddo
4699       enddo
4700 #endif
4701 c
4702 c     do iref=1,nref
4703 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4704 c     write (iout,*) "waga_theta",waga_theta
4705       if (waga_theta.gt.0.0d0) then
4706 #ifdef DEBUG
4707       write (iout,*) "usampl",usampl
4708       write(iout,*) "------- theta restrs start -------"
4709 c     do i=ithet_start,ithet_end
4710 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4711 c     enddo
4712 #endif
4713 c     write (iout,*) "maxres",maxres,"nres",nres
4714
4715       do i=ithet_start,ithet_end
4716 c
4717 c     do i=1,nfrag_back
4718 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4719 c
4720 c Deviation of theta angles wrt constr_homology ref structures
4721 c
4722         utheta_i=0.0d0 ! argument of Gaussian for single k
4723         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4724 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4725 c       over residues in a fragment
4726 c       write (iout,*) "theta(",i,")=",theta(i)
4727         do k=1,constr_homology
4728 c
4729 c         dtheta_i=theta(j)-thetaref(j,iref)
4730 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4731           theta_diff(k)=thetatpl(k,i)-theta(i)
4732 c
4733           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4734 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4735           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4736           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4737 c         Gradient for single Gaussian restraint in subr Econstr_back
4738 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4739 c
4740         enddo
4741 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4742 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4743
4744 c
4745 #ifdef GRAD
4746 c         Gradient for multiple Gaussian restraint
4747         sum_gtheta=gutheta_i
4748         sum_sgtheta=0.0d0
4749         do k=1,constr_homology
4750 c        New generalized expr for multiple Gaussian from Econstr_back
4751          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4752 c
4753 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4754           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4755         enddo
4756 c
4757 c       Final value of gradient using same var as in Econstr_back
4758         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4759      &               *waga_homology(iset)
4760 c       dutheta(i)=sum_sgtheta/sum_gtheta
4761 c
4762 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4763 #endif
4764         Eval=Eval-dLOG(gutheta_i/constr_homology)
4765 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4766 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4767 c       Uconst_back=Uconst_back+utheta(i)
4768       enddo ! (i-loop for theta)
4769 #ifdef DEBUG
4770       write(iout,*) "------- theta restrs end -------"
4771 #endif
4772       endif
4773 c
4774 c Deviation of local SC geometry
4775 c
4776 c Separation of two i-loops (instructed by AL - 11/3/2014)
4777 c
4778 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4779 c     write (iout,*) "waga_d",waga_d
4780
4781 #ifdef DEBUG
4782       write(iout,*) "------- SC restrs start -------"
4783       write (iout,*) "Initial duscdiff,duscdiffx"
4784       do i=loc_start,loc_end
4785         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4786      &                 (duscdiffx(jik,i),jik=1,3)
4787       enddo
4788 #endif
4789       do i=loc_start,loc_end
4790         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4791         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4792 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4793 c       write(iout,*) "xxtab, yytab, zztab"
4794 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4795         do k=1,constr_homology
4796 c
4797           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4798 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4799           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4800           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4801 c         write(iout,*) "dxx, dyy, dzz"
4802 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4803 c
4804           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4805 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4806 c         uscdiffk(k)=usc_diff(i)
4807           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4808           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4809 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4810 c     &      xxref(j),yyref(j),zzref(j)
4811         enddo
4812 c
4813 c       Gradient
4814 c
4815 c       Generalized expression for multiple Gaussian acc to that for a single
4816 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4817 c
4818 c       Original implementation
4819 c       sum_guscdiff=guscdiff(i)
4820 c
4821 c       sum_sguscdiff=0.0d0
4822 c       do k=1,constr_homology
4823 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4824 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4825 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4826 c       enddo
4827 c
4828 c       Implementation of new expressions for gradient (Jan. 2015)
4829 c
4830 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4831 #ifdef GRAD
4832         do k=1,constr_homology
4833 c
4834 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4835 c       before. Now the drivatives should be correct
4836 c
4837           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4838 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4839           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4840           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4841 c
4842 c         New implementation
4843 c
4844           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4845      &                 sigma_d(k,i) ! for the grad wrt r'
4846 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4847 c
4848 c
4849 c        New implementation
4850          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4851          do jik=1,3
4852             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4853      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4854      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4855             duscdiff(jik,i)=duscdiff(jik,i)+
4856      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4857      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4858             duscdiffx(jik,i)=duscdiffx(jik,i)+
4859      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4860      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4861 c
4862 #ifdef DEBUG
4863              write(iout,*) "jik",jik,"i",i
4864              write(iout,*) "dxx, dyy, dzz"
4865              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4866              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4867 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4868 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4869 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4870 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4871 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4872 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4873 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4874 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4875 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4876 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4877 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4878 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4879 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4880 c            endif
4881 #endif
4882          enddo
4883         enddo
4884 #endif
4885 c
4886 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4887 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4888 c
4889 c        write (iout,*) i," uscdiff",uscdiff(i)
4890 c
4891 c Put together deviations from local geometry
4892
4893 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4894 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4895         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4896 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4897 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4898 c       Uconst_back=Uconst_back+usc_diff(i)
4899 c
4900 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4901 c
4902 c     New implment: multiplied by sum_sguscdiff
4903 c
4904
4905       enddo ! (i-loop for dscdiff)
4906
4907 c      endif
4908
4909 #ifdef DEBUG
4910       write(iout,*) "------- SC restrs end -------"
4911         write (iout,*) "------ After SC loop in e_modeller ------"
4912         do i=loc_start,loc_end
4913          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4914          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4915         enddo
4916       if (waga_theta.eq.1.0d0) then
4917       write (iout,*) "in e_modeller after SC restr end: dutheta"
4918       do i=ithet_start,ithet_end
4919         write (iout,*) i,dutheta(i)
4920       enddo
4921       endif
4922       if (waga_d.eq.1.0d0) then
4923       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4924       do i=1,nres
4925         write (iout,*) i,(duscdiff(j,i),j=1,3)
4926         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4927       enddo
4928       endif
4929 #endif
4930
4931 c Total energy from homology restraints
4932 #ifdef DEBUG
4933       write (iout,*) "odleg",odleg," kat",kat
4934       write (iout,*) "odleg",odleg," kat",kat
4935       write (iout,*) "Eval",Eval," Erot",Erot
4936       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4937       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4938       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4939 #endif
4940 c
4941 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4942 c
4943 c     ehomology_constr=odleg+kat
4944 c
4945 c     For Lorentzian-type Urestr
4946 c
4947
4948       if (waga_dist.ge.0.0d0) then
4949 c
4950 c          For Gaussian-type Urestr
4951 c
4952 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4953 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4954         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4955      &              waga_theta*Eval+waga_d*Erot
4956 c     write (iout,*) "ehomology_constr=",ehomology_constr
4957       else
4958 c
4959 c          For Lorentzian-type Urestr
4960 c
4961 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4962 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4963         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4964      &              waga_theta*Eval+waga_d*Erot
4965 c     write (iout,*) "ehomology_constr=",ehomology_constr
4966       endif
4967 #ifdef DEBUG
4968       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4969      & "Eval",waga_theta,eval,
4970      &   "Erot",waga_d,Erot
4971       write (iout,*) "ehomology_constr",ehomology_constr
4972 #endif
4973       return
4974
4975   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4976   747 format(a12,i4,i4,i4,f8.3,f8.3)
4977   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4978   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4979   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4980      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4981       end
4982 c-----------------------------------------------------------------------
4983       subroutine ebond(estr)
4984 c
4985 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4986 c
4987       implicit real*8 (a-h,o-z)
4988       include 'DIMENSIONS'
4989       include 'DIMENSIONS.ZSCOPT'
4990       include 'COMMON.LOCAL'
4991       include 'COMMON.GEO'
4992       include 'COMMON.INTERACT'
4993       include 'COMMON.DERIV'
4994       include 'COMMON.VAR'
4995       include 'COMMON.CHAIN'
4996       include 'COMMON.IOUNITS'
4997       include 'COMMON.NAMES'
4998       include 'COMMON.FFIELD'
4999       include 'COMMON.CONTROL'
5000       double precision u(3),ud(3)
5001       estr=0.0d0
5002       estr1=0.0d0
5003 c      write (iout,*) "distchainmax",distchainmax
5004       do i=nnt+1,nct
5005 #ifdef FIVEDIAG
5006         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5007         diff = vbld(i)-vbldp0
5008 #else
5009         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5010 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5011 C          do j=1,3
5012 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5013 C     &      *dc(j,i-1)/vbld(i)
5014 C          enddo
5015 C          if (energy_dec) write(iout,*)
5016 C     &       "estr1",i,vbld(i),distchainmax,
5017 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5018 C        else
5019          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5020         diff = vbld(i)-vbldpDUM
5021 C         write(iout,*) i,diff
5022          else
5023           diff = vbld(i)-vbldp0
5024 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5025          endif
5026 #endif
5027           estr=estr+diff*diff
5028           do j=1,3
5029             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5030           enddo
5031 C        endif
5032           if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5033      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5034       enddo
5035       estr=0.5d0*AKP*estr+estr1
5036 c
5037 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5038 c
5039       do i=nnt,nct
5040         iti=iabs(itype(i))
5041         if (iti.ne.10 .and. iti.ne.ntyp1) then
5042           nbi=nbondterm(iti)
5043           if (nbi.eq.1) then
5044             diff=vbld(i+nres)-vbldsc0(1,iti)
5045             if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
5046      &      vbldsc0(1,iti),diff,
5047      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5048             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5049             do j=1,3
5050               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5051             enddo
5052           else
5053             do j=1,nbi
5054               diff=vbld(i+nres)-vbldsc0(j,iti)
5055               ud(j)=aksc(j,iti)*diff
5056               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5057             enddo
5058             uprod=u(1)
5059             do j=2,nbi
5060               uprod=uprod*u(j)
5061             enddo
5062             usum=0.0d0
5063             usumsqder=0.0d0
5064             do j=1,nbi
5065               uprod1=1.0d0
5066               uprod2=1.0d0
5067               do k=1,nbi
5068                 if (k.ne.j) then
5069                   uprod1=uprod1*u(k)
5070                   uprod2=uprod2*u(k)*u(k)
5071                 endif
5072               enddo
5073               usum=usum+uprod1
5074               usumsqder=usumsqder+ud(j)*uprod2
5075             enddo
5076 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5077 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5078             estr=estr+uprod/usum
5079             do j=1,3
5080              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5081             enddo
5082           endif
5083         endif
5084       enddo
5085       return
5086       end
5087 #ifdef CRYST_THETA
5088 C--------------------------------------------------------------------------
5089       subroutine ebend(etheta,ethetacnstr)
5090 C
5091 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5092 C angles gamma and its derivatives in consecutive thetas and gammas.
5093 C
5094       implicit real*8 (a-h,o-z)
5095       include 'DIMENSIONS'
5096       include 'DIMENSIONS.ZSCOPT'
5097       include 'COMMON.LOCAL'
5098       include 'COMMON.GEO'
5099       include 'COMMON.INTERACT'
5100       include 'COMMON.DERIV'
5101       include 'COMMON.VAR'
5102       include 'COMMON.CHAIN'
5103       include 'COMMON.IOUNITS'
5104       include 'COMMON.NAMES'
5105       include 'COMMON.FFIELD'
5106       include 'COMMON.TORCNSTR'
5107       common /calcthet/ term1,term2,termm,diffak,ratak,
5108      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5109      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5110       double precision y(2),z(2)
5111       delta=0.02d0*pi
5112 c      time11=dexp(-2*time)
5113 c      time12=1.0d0
5114       etheta=0.0D0
5115 c      write (iout,*) "nres",nres
5116 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5117 c      write (iout,*) ithet_start,ithet_end
5118       do i=ithet_start,ithet_end
5119 C        if (itype(i-1).eq.ntyp1) cycle
5120         if (i.le.2) cycle
5121         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5122      &  .or.itype(i).eq.ntyp1) cycle
5123 C Zero the energy function and its derivative at 0 or pi.
5124         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5125         it=itype(i-1)
5126         ichir1=isign(1,itype(i-2))
5127         ichir2=isign(1,itype(i))
5128          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5129          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5130          if (itype(i-1).eq.10) then
5131           itype1=isign(10,itype(i-2))
5132           ichir11=isign(1,itype(i-2))
5133           ichir12=isign(1,itype(i-2))
5134           itype2=isign(10,itype(i))
5135           ichir21=isign(1,itype(i))
5136           ichir22=isign(1,itype(i))
5137          endif
5138          if (i.eq.3) then
5139           y(1)=0.0D0
5140           y(2)=0.0D0
5141           else
5142
5143         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5144 #ifdef OSF
5145           phii=phi(i)
5146 c          icrc=0
5147 c          call proc_proc(phii,icrc)
5148           if (icrc.eq.1) phii=150.0
5149 #else
5150           phii=phi(i)
5151 #endif
5152           y(1)=dcos(phii)
5153           y(2)=dsin(phii)
5154         else
5155           y(1)=0.0D0
5156           y(2)=0.0D0
5157         endif
5158         endif
5159         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5160 #ifdef OSF
5161           phii1=phi(i+1)
5162 c          icrc=0
5163 c          call proc_proc(phii1,icrc)
5164           if (icrc.eq.1) phii1=150.0
5165           phii1=pinorm(phii1)
5166           z(1)=cos(phii1)
5167 #else
5168           phii1=phi(i+1)
5169           z(1)=dcos(phii1)
5170 #endif
5171           z(2)=dsin(phii1)
5172         else
5173           z(1)=0.0D0
5174           z(2)=0.0D0
5175         endif
5176 C Calculate the "mean" value of theta from the part of the distribution
5177 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5178 C In following comments this theta will be referred to as t_c.
5179         thet_pred_mean=0.0d0
5180         do k=1,2
5181             athetk=athet(k,it,ichir1,ichir2)
5182             bthetk=bthet(k,it,ichir1,ichir2)
5183           if (it.eq.10) then
5184              athetk=athet(k,itype1,ichir11,ichir12)
5185              bthetk=bthet(k,itype2,ichir21,ichir22)
5186           endif
5187           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5188         enddo
5189 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5190         dthett=thet_pred_mean*ssd
5191         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5192 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5193 C Derivatives of the "mean" values in gamma1 and gamma2.
5194         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5195      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5196          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5197      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5198          if (it.eq.10) then
5199       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5200      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5201         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5202      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5203          endif
5204         if (theta(i).gt.pi-delta) then
5205           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5206      &         E_tc0)
5207           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5208           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5209           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5210      &        E_theta)
5211           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5212      &        E_tc)
5213         else if (theta(i).lt.delta) then
5214           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5215           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5216           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5217      &        E_theta)
5218           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5219           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5220      &        E_tc)
5221         else
5222           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5223      &        E_theta,E_tc)
5224         endif
5225         etheta=etheta+ethetai
5226 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5227 c     &      'ebend',i,ethetai,theta(i),itype(i)
5228 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5229 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5230         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5231         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5232         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5233 c 1215   continue
5234       enddo
5235       ethetacnstr=0.0d0
5236 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5237       do i=1,ntheta_constr
5238         itheta=itheta_constr(i)
5239         thetiii=theta(itheta)
5240         difi=pinorm(thetiii-theta_constr0(i))
5241         if (difi.gt.theta_drange(i)) then
5242           difi=difi-theta_drange(i)
5243           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5244           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5245      &    +for_thet_constr(i)*difi**3
5246         else if (difi.lt.-drange(i)) then
5247           difi=difi+drange(i)
5248           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5249           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5250      &    +for_thet_constr(i)*difi**3
5251         else
5252           difi=0.0
5253         endif
5254 C       if (energy_dec) then
5255 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5256 C     &    i,itheta,rad2deg*thetiii,
5257 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5258 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5259 C     &    gloc(itheta+nphi-2,icg)
5260 C        endif
5261       enddo
5262 C Ufff.... We've done all this!!!
5263       return
5264       end
5265 C---------------------------------------------------------------------------
5266       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5267      &     E_tc)
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'COMMON.LOCAL'
5271       include 'COMMON.IOUNITS'
5272       common /calcthet/ term1,term2,termm,diffak,ratak,
5273      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5274      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5275 C Calculate the contributions to both Gaussian lobes.
5276 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5277 C The "polynomial part" of the "standard deviation" of this part of
5278 C the distribution.
5279         sig=polthet(3,it)
5280         do j=2,0,-1
5281           sig=sig*thet_pred_mean+polthet(j,it)
5282         enddo
5283 C Derivative of the "interior part" of the "standard deviation of the"
5284 C gamma-dependent Gaussian lobe in t_c.
5285         sigtc=3*polthet(3,it)
5286         do j=2,1,-1
5287           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5288         enddo
5289         sigtc=sig*sigtc
5290 C Set the parameters of both Gaussian lobes of the distribution.
5291 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5292         fac=sig*sig+sigc0(it)
5293         sigcsq=fac+fac
5294         sigc=1.0D0/sigcsq
5295 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5296         sigsqtc=-4.0D0*sigcsq*sigtc
5297 c       print *,i,sig,sigtc,sigsqtc
5298 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5299         sigtc=-sigtc/(fac*fac)
5300 C Following variable is sigma(t_c)**(-2)
5301         sigcsq=sigcsq*sigcsq
5302         sig0i=sig0(it)
5303         sig0inv=1.0D0/sig0i**2
5304         delthec=thetai-thet_pred_mean
5305         delthe0=thetai-theta0i
5306         term1=-0.5D0*sigcsq*delthec*delthec
5307         term2=-0.5D0*sig0inv*delthe0*delthe0
5308 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5309 C NaNs in taking the logarithm. We extract the largest exponent which is added
5310 C to the energy (this being the log of the distribution) at the end of energy
5311 C term evaluation for this virtual-bond angle.
5312         if (term1.gt.term2) then
5313           termm=term1
5314           term2=dexp(term2-termm)
5315           term1=1.0d0
5316         else
5317           termm=term2
5318           term1=dexp(term1-termm)
5319           term2=1.0d0
5320         endif
5321 C The ratio between the gamma-independent and gamma-dependent lobes of
5322 C the distribution is a Gaussian function of thet_pred_mean too.
5323         diffak=gthet(2,it)-thet_pred_mean
5324         ratak=diffak/gthet(3,it)**2
5325         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5326 C Let's differentiate it in thet_pred_mean NOW.
5327         aktc=ak*ratak
5328 C Now put together the distribution terms to make complete distribution.
5329         termexp=term1+ak*term2
5330         termpre=sigc+ak*sig0i
5331 C Contribution of the bending energy from this theta is just the -log of
5332 C the sum of the contributions from the two lobes and the pre-exponential
5333 C factor. Simple enough, isn't it?
5334         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5335 C NOW the derivatives!!!
5336 C 6/6/97 Take into account the deformation.
5337         E_theta=(delthec*sigcsq*term1
5338      &       +ak*delthe0*sig0inv*term2)/termexp
5339         E_tc=((sigtc+aktc*sig0i)/termpre
5340      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5341      &       aktc*term2)/termexp)
5342       return
5343       end
5344 c-----------------------------------------------------------------------------
5345       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5346       implicit real*8 (a-h,o-z)
5347       include 'DIMENSIONS'
5348       include 'COMMON.LOCAL'
5349       include 'COMMON.IOUNITS'
5350       common /calcthet/ term1,term2,termm,diffak,ratak,
5351      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5352      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5353       delthec=thetai-thet_pred_mean
5354       delthe0=thetai-theta0i
5355 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5356       t3 = thetai-thet_pred_mean
5357       t6 = t3**2
5358       t9 = term1
5359       t12 = t3*sigcsq
5360       t14 = t12+t6*sigsqtc
5361       t16 = 1.0d0
5362       t21 = thetai-theta0i
5363       t23 = t21**2
5364       t26 = term2
5365       t27 = t21*t26
5366       t32 = termexp
5367       t40 = t32**2
5368       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5369      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5370      & *(-t12*t9-ak*sig0inv*t27)
5371       return
5372       end
5373 #else
5374 C--------------------------------------------------------------------------
5375       subroutine ebend(etheta)
5376 C
5377 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5378 C angles gamma and its derivatives in consecutive thetas and gammas.
5379 C ab initio-derived potentials from
5380 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5381 C
5382       implicit real*8 (a-h,o-z)
5383       include 'DIMENSIONS'
5384       include 'DIMENSIONS.ZSCOPT'
5385       include 'COMMON.LOCAL'
5386       include 'COMMON.GEO'
5387       include 'COMMON.INTERACT'
5388       include 'COMMON.DERIV'
5389       include 'COMMON.VAR'
5390       include 'COMMON.CHAIN'
5391       include 'COMMON.IOUNITS'
5392       include 'COMMON.NAMES'
5393       include 'COMMON.FFIELD'
5394       include 'COMMON.CONTROL'
5395       include 'COMMON.TORCNSTR'
5396       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5397      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5398      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5399      & sinph1ph2(maxdouble,maxdouble)
5400       logical lprn /.false./, lprn1 /.false./
5401       etheta=0.0D0
5402 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5403       do i=ithet_start,ithet_end
5404 C         if (i.eq.2) cycle
5405 C        if (itype(i-1).eq.ntyp1) cycle
5406         if (i.le.2) cycle
5407         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5408      &  .or.itype(i).eq.ntyp1) cycle
5409         if (iabs(itype(i+1)).eq.20) iblock=2
5410         if (iabs(itype(i+1)).ne.20) iblock=1
5411         dethetai=0.0d0
5412         dephii=0.0d0
5413         dephii1=0.0d0
5414         theti2=0.5d0*theta(i)
5415         ityp2=ithetyp((itype(i-1)))
5416         do k=1,nntheterm
5417           coskt(k)=dcos(k*theti2)
5418           sinkt(k)=dsin(k*theti2)
5419         enddo
5420 cu        if (i.eq.3) then
5421 cu          phii=0.0d0
5422 cu          ityp1=nthetyp+1
5423 cu          do k=1,nsingle
5424 cu            cosph1(k)=0.0d0
5425 cu            sinph1(k)=0.0d0
5426 cu          enddo
5427 cu        else
5428         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5429 #ifdef OSF
5430           phii=phi(i)
5431           if (phii.ne.phii) phii=150.0
5432 #else
5433           phii=phi(i)
5434 #endif
5435           ityp1=ithetyp((itype(i-2)))
5436           do k=1,nsingle
5437             cosph1(k)=dcos(k*phii)
5438             sinph1(k)=dsin(k*phii)
5439           enddo
5440         else
5441           phii=0.0d0
5442 c          ityp1=nthetyp+1
5443           do k=1,nsingle
5444             ityp1=ithetyp((itype(i-2)))
5445             cosph1(k)=0.0d0
5446             sinph1(k)=0.0d0
5447           enddo
5448         endif
5449         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5450 #ifdef OSF
5451           phii1=phi(i+1)
5452           if (phii1.ne.phii1) phii1=150.0
5453           phii1=pinorm(phii1)
5454 #else
5455           phii1=phi(i+1)
5456 #endif
5457           ityp3=ithetyp((itype(i)))
5458           do k=1,nsingle
5459             cosph2(k)=dcos(k*phii1)
5460             sinph2(k)=dsin(k*phii1)
5461           enddo
5462         else
5463           phii1=0.0d0
5464 c          ityp3=nthetyp+1
5465           ityp3=ithetyp((itype(i)))
5466           do k=1,nsingle
5467             cosph2(k)=0.0d0
5468             sinph2(k)=0.0d0
5469           enddo
5470         endif
5471 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5472 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5473 c        call flush(iout)
5474         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5475         do k=1,ndouble
5476           do l=1,k-1
5477             ccl=cosph1(l)*cosph2(k-l)
5478             ssl=sinph1(l)*sinph2(k-l)
5479             scl=sinph1(l)*cosph2(k-l)
5480             csl=cosph1(l)*sinph2(k-l)
5481             cosph1ph2(l,k)=ccl-ssl
5482             cosph1ph2(k,l)=ccl+ssl
5483             sinph1ph2(l,k)=scl+csl
5484             sinph1ph2(k,l)=scl-csl
5485           enddo
5486         enddo
5487         if (lprn) then
5488         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5489      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5490         write (iout,*) "coskt and sinkt"
5491         do k=1,nntheterm
5492           write (iout,*) k,coskt(k),sinkt(k)
5493         enddo
5494         endif
5495         do k=1,ntheterm
5496           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5497           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5498      &      *coskt(k)
5499           if (lprn)
5500      &    write (iout,*) "k",k,"
5501      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5502      &     " ethetai",ethetai
5503         enddo
5504         if (lprn) then
5505         write (iout,*) "cosph and sinph"
5506         do k=1,nsingle
5507           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5508         enddo
5509         write (iout,*) "cosph1ph2 and sinph2ph2"
5510         do k=2,ndouble
5511           do l=1,k-1
5512             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5513      &         sinph1ph2(l,k),sinph1ph2(k,l)
5514           enddo
5515         enddo
5516         write(iout,*) "ethetai",ethetai
5517         endif
5518         do m=1,ntheterm2
5519           do k=1,nsingle
5520             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5521      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5522      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5523      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5524             ethetai=ethetai+sinkt(m)*aux
5525             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5526             dephii=dephii+k*sinkt(m)*(
5527      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5528      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5529             dephii1=dephii1+k*sinkt(m)*(
5530      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5531      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5532             if (lprn)
5533      &      write (iout,*) "m",m," k",k," bbthet",
5534      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5535      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5536      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5537      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5538           enddo
5539         enddo
5540         if (lprn)
5541      &  write(iout,*) "ethetai",ethetai
5542         do m=1,ntheterm3
5543           do k=2,ndouble
5544             do l=1,k-1
5545               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5546      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5547      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5548      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5549               ethetai=ethetai+sinkt(m)*aux
5550               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5551               dephii=dephii+l*sinkt(m)*(
5552      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5553      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5554      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5555      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5556               dephii1=dephii1+(k-l)*sinkt(m)*(
5557      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5558      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5559      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5560      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5561               if (lprn) then
5562               write (iout,*) "m",m," k",k," l",l," ffthet",
5563      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5564      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5565      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5566      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5567      &            " ethetai",ethetai
5568               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5569      &            cosph1ph2(k,l)*sinkt(m),
5570      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5571               endif
5572             enddo
5573           enddo
5574         enddo
5575 10      continue
5576         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5577      &   i,theta(i)*rad2deg,phii*rad2deg,
5578      &   phii1*rad2deg,ethetai
5579         etheta=etheta+ethetai
5580         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5581         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5582 c        gloc(nphi+i-2,icg)=wang*dethetai
5583         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5584       enddo
5585       return
5586       end
5587 #endif
5588 #ifdef CRYST_SC
5589 c-----------------------------------------------------------------------------
5590       subroutine esc(escloc)
5591 C Calculate the local energy of a side chain and its derivatives in the
5592 C corresponding virtual-bond valence angles THETA and the spherical angles
5593 C ALPHA and OMEGA.
5594       implicit real*8 (a-h,o-z)
5595       include 'DIMENSIONS'
5596       include 'DIMENSIONS.ZSCOPT'
5597       include 'COMMON.GEO'
5598       include 'COMMON.LOCAL'
5599       include 'COMMON.VAR'
5600       include 'COMMON.INTERACT'
5601       include 'COMMON.DERIV'
5602       include 'COMMON.CHAIN'
5603       include 'COMMON.IOUNITS'
5604       include 'COMMON.NAMES'
5605       include 'COMMON.FFIELD'
5606       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5607      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5608       common /sccalc/ time11,time12,time112,theti,it,nlobit
5609       delta=0.02d0*pi
5610       escloc=0.0D0
5611 C      write (iout,*) 'ESC'
5612       do i=loc_start,loc_end
5613         it=itype(i)
5614         if (it.eq.ntyp1) cycle
5615         if (it.eq.10) goto 1
5616         nlobit=nlob(iabs(it))
5617 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5618 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5619         theti=theta(i+1)-pipol
5620         x(1)=dtan(theti)
5621         x(2)=alph(i)
5622         x(3)=omeg(i)
5623 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5624
5625         if (x(2).gt.pi-delta) then
5626           xtemp(1)=x(1)
5627           xtemp(2)=pi-delta
5628           xtemp(3)=x(3)
5629           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5630           xtemp(2)=pi
5631           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5632           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5633      &        escloci,dersc(2))
5634           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5635      &        ddersc0(1),dersc(1))
5636           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5637      &        ddersc0(3),dersc(3))
5638           xtemp(2)=pi-delta
5639           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5640           xtemp(2)=pi
5641           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5642           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5643      &            dersc0(2),esclocbi,dersc02)
5644           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5645      &            dersc12,dersc01)
5646           call splinthet(x(2),0.5d0*delta,ss,ssd)
5647           dersc0(1)=dersc01
5648           dersc0(2)=dersc02
5649           dersc0(3)=0.0d0
5650           do k=1,3
5651             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5652           enddo
5653           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5654           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5655      &             esclocbi,ss,ssd
5656           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5657 c         escloci=esclocbi
5658 c         write (iout,*) escloci
5659         else if (x(2).lt.delta) then
5660           xtemp(1)=x(1)
5661           xtemp(2)=delta
5662           xtemp(3)=x(3)
5663           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5664           xtemp(2)=0.0d0
5665           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5666           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5667      &        escloci,dersc(2))
5668           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5669      &        ddersc0(1),dersc(1))
5670           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5671      &        ddersc0(3),dersc(3))
5672           xtemp(2)=delta
5673           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5674           xtemp(2)=0.0d0
5675           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5676           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5677      &            dersc0(2),esclocbi,dersc02)
5678           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5679      &            dersc12,dersc01)
5680           dersc0(1)=dersc01
5681           dersc0(2)=dersc02
5682           dersc0(3)=0.0d0
5683           call splinthet(x(2),0.5d0*delta,ss,ssd)
5684           do k=1,3
5685             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5686           enddo
5687           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5688 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5689 c     &             esclocbi,ss,ssd
5690           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5691 C         write (iout,*) 'i=',i, escloci
5692         else
5693           call enesc(x,escloci,dersc,ddummy,.false.)
5694         endif
5695
5696         escloc=escloc+escloci
5697 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5698             write (iout,'(a6,i5,0pf7.3)')
5699      &     'escloc',i,escloci
5700
5701         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5702      &   wscloc*dersc(1)
5703         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5704         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5705     1   continue
5706       enddo
5707       return
5708       end
5709 C---------------------------------------------------------------------------
5710       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5711       implicit real*8 (a-h,o-z)
5712       include 'DIMENSIONS'
5713       include 'COMMON.GEO'
5714       include 'COMMON.LOCAL'
5715       include 'COMMON.IOUNITS'
5716       common /sccalc/ time11,time12,time112,theti,it,nlobit
5717       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5718       double precision contr(maxlob,-1:1)
5719       logical mixed
5720 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5721         escloc_i=0.0D0
5722         do j=1,3
5723           dersc(j)=0.0D0
5724           if (mixed) ddersc(j)=0.0d0
5725         enddo
5726         x3=x(3)
5727
5728 C Because of periodicity of the dependence of the SC energy in omega we have
5729 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5730 C To avoid underflows, first compute & store the exponents.
5731
5732         do iii=-1,1
5733
5734           x(3)=x3+iii*dwapi
5735
5736           do j=1,nlobit
5737             do k=1,3
5738               z(k)=x(k)-censc(k,j,it)
5739             enddo
5740             do k=1,3
5741               Axk=0.0D0
5742               do l=1,3
5743                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5744               enddo
5745               Ax(k,j,iii)=Axk
5746             enddo
5747             expfac=0.0D0
5748             do k=1,3
5749               expfac=expfac+Ax(k,j,iii)*z(k)
5750             enddo
5751             contr(j,iii)=expfac
5752           enddo ! j
5753
5754         enddo ! iii
5755
5756         x(3)=x3
5757 C As in the case of ebend, we want to avoid underflows in exponentiation and
5758 C subsequent NaNs and INFs in energy calculation.
5759 C Find the largest exponent
5760         emin=contr(1,-1)
5761         do iii=-1,1
5762           do j=1,nlobit
5763             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5764           enddo
5765         enddo
5766         emin=0.5D0*emin
5767 cd      print *,'it=',it,' emin=',emin
5768
5769 C Compute the contribution to SC energy and derivatives
5770         do iii=-1,1
5771
5772           do j=1,nlobit
5773             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5774 cd          print *,'j=',j,' expfac=',expfac
5775             escloc_i=escloc_i+expfac
5776             do k=1,3
5777               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5778             enddo
5779             if (mixed) then
5780               do k=1,3,2
5781                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5782      &            +gaussc(k,2,j,it))*expfac
5783               enddo
5784             endif
5785           enddo
5786
5787         enddo ! iii
5788
5789         dersc(1)=dersc(1)/cos(theti)**2
5790         ddersc(1)=ddersc(1)/cos(theti)**2
5791         ddersc(3)=ddersc(3)
5792
5793         escloci=-(dlog(escloc_i)-emin)
5794         do j=1,3
5795           dersc(j)=dersc(j)/escloc_i
5796         enddo
5797         if (mixed) then
5798           do j=1,3,2
5799             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5800           enddo
5801         endif
5802       return
5803       end
5804 C------------------------------------------------------------------------------
5805       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'COMMON.GEO'
5809       include 'COMMON.LOCAL'
5810       include 'COMMON.IOUNITS'
5811       common /sccalc/ time11,time12,time112,theti,it,nlobit
5812       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5813       double precision contr(maxlob)
5814       logical mixed
5815
5816       escloc_i=0.0D0
5817
5818       do j=1,3
5819         dersc(j)=0.0D0
5820       enddo
5821
5822       do j=1,nlobit
5823         do k=1,2
5824           z(k)=x(k)-censc(k,j,it)
5825         enddo
5826         z(3)=dwapi
5827         do k=1,3
5828           Axk=0.0D0
5829           do l=1,3
5830             Axk=Axk+gaussc(l,k,j,it)*z(l)
5831           enddo
5832           Ax(k,j)=Axk
5833         enddo
5834         expfac=0.0D0
5835         do k=1,3
5836           expfac=expfac+Ax(k,j)*z(k)
5837         enddo
5838         contr(j)=expfac
5839       enddo ! j
5840
5841 C As in the case of ebend, we want to avoid underflows in exponentiation and
5842 C subsequent NaNs and INFs in energy calculation.
5843 C Find the largest exponent
5844       emin=contr(1)
5845       do j=1,nlobit
5846         if (emin.gt.contr(j)) emin=contr(j)
5847       enddo
5848       emin=0.5D0*emin
5849
5850 C Compute the contribution to SC energy and derivatives
5851
5852       dersc12=0.0d0
5853       do j=1,nlobit
5854         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5855         escloc_i=escloc_i+expfac
5856         do k=1,2
5857           dersc(k)=dersc(k)+Ax(k,j)*expfac
5858         enddo
5859         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5860      &            +gaussc(1,2,j,it))*expfac
5861         dersc(3)=0.0d0
5862       enddo
5863
5864       dersc(1)=dersc(1)/cos(theti)**2
5865       dersc12=dersc12/cos(theti)**2
5866       escloci=-(dlog(escloc_i)-emin)
5867       do j=1,2
5868         dersc(j)=dersc(j)/escloc_i
5869       enddo
5870       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5871       return
5872       end
5873 #else
5874 c----------------------------------------------------------------------------------
5875       subroutine esc(escloc)
5876 C Calculate the local energy of a side chain and its derivatives in the
5877 C corresponding virtual-bond valence angles THETA and the spherical angles
5878 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5879 C added by Urszula Kozlowska. 07/11/2007
5880 C
5881       implicit real*8 (a-h,o-z)
5882       include 'DIMENSIONS'
5883       include 'DIMENSIONS.ZSCOPT'
5884       include 'COMMON.GEO'
5885       include 'COMMON.LOCAL'
5886       include 'COMMON.VAR'
5887       include 'COMMON.SCROT'
5888       include 'COMMON.INTERACT'
5889       include 'COMMON.DERIV'
5890       include 'COMMON.CHAIN'
5891       include 'COMMON.IOUNITS'
5892       include 'COMMON.NAMES'
5893       include 'COMMON.FFIELD'
5894       include 'COMMON.CONTROL'
5895       include 'COMMON.VECTORS'
5896       double precision x_prime(3),y_prime(3),z_prime(3)
5897      &    , sumene,dsc_i,dp2_i,x(65),
5898      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5899      &    de_dxx,de_dyy,de_dzz,de_dt
5900       double precision s1_t,s1_6_t,s2_t,s2_6_t
5901       double precision
5902      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5903      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5904      & dt_dCi(3),dt_dCi1(3)
5905       common /sccalc/ time11,time12,time112,theti,it,nlobit
5906       delta=0.02d0*pi
5907       escloc=0.0D0
5908       do i=loc_start,loc_end
5909         if (itype(i).eq.ntyp1) cycle
5910         costtab(i+1) =dcos(theta(i+1))
5911         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5912         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5913         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5914         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5915         cosfac=dsqrt(cosfac2)
5916         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5917         sinfac=dsqrt(sinfac2)
5918         it=iabs(itype(i))
5919         if (it.eq.10) goto 1
5920 c
5921 C  Compute the axes of tghe local cartesian coordinates system; store in
5922 c   x_prime, y_prime and z_prime
5923 c
5924         do j=1,3
5925           x_prime(j) = 0.00
5926           y_prime(j) = 0.00
5927           z_prime(j) = 0.00
5928         enddo
5929 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5930 C     &   dc_norm(3,i+nres)
5931         do j = 1,3
5932           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5933           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5934         enddo
5935         do j = 1,3
5936           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5937         enddo
5938 c       write (2,*) "i",i
5939 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5940 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5941 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5942 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5943 c      & " xy",scalar(x_prime(1),y_prime(1)),
5944 c      & " xz",scalar(x_prime(1),z_prime(1)),
5945 c      & " yy",scalar(y_prime(1),y_prime(1)),
5946 c      & " yz",scalar(y_prime(1),z_prime(1)),
5947 c      & " zz",scalar(z_prime(1),z_prime(1))
5948 c
5949 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5950 C to local coordinate system. Store in xx, yy, zz.
5951 c
5952         xx=0.0d0
5953         yy=0.0d0
5954         zz=0.0d0
5955         do j = 1,3
5956           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5957           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5958           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5959         enddo
5960
5961         xxtab(i)=xx
5962         yytab(i)=yy
5963         zztab(i)=zz
5964 C
5965 C Compute the energy of the ith side cbain
5966 C
5967 c        write (2,*) "xx",xx," yy",yy," zz",zz
5968         it=iabs(itype(i))
5969         do j = 1,65
5970           x(j) = sc_parmin(j,it)
5971         enddo
5972 #ifdef CHECK_COORD
5973 Cc diagnostics - remove later
5974         xx1 = dcos(alph(2))
5975         yy1 = dsin(alph(2))*dcos(omeg(2))
5976         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5977         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5978      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5979      &    xx1,yy1,zz1
5980 C,"  --- ", xx_w,yy_w,zz_w
5981 c end diagnostics
5982 #endif
5983         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5984      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5985      &   + x(10)*yy*zz
5986         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5987      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5988      & + x(20)*yy*zz
5989         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5990      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5991      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5992      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5993      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5994      &  +x(40)*xx*yy*zz
5995         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5996      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5997      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5998      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5999      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6000      &  +x(60)*xx*yy*zz
6001         dsc_i   = 0.743d0+x(61)
6002         dp2_i   = 1.9d0+x(62)
6003         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6004      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6005         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6006      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6007         s1=(1+x(63))/(0.1d0 + dscp1)
6008         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6009         s2=(1+x(65))/(0.1d0 + dscp2)
6010         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6011         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6012      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6013 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6014 c     &   sumene4,
6015 c     &   dscp1,dscp2,sumene
6016 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6017         escloc = escloc + sumene
6018 c        write (2,*) "escloc",escloc
6019 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6020 c     &  zz,xx,yy
6021         if (.not. calc_grad) goto 1
6022 #ifdef DEBUG
6023 C
6024 C This section to check the numerical derivatives of the energy of ith side
6025 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6026 C #define DEBUG in the code to turn it on.
6027 C
6028         write (2,*) "sumene               =",sumene
6029         aincr=1.0d-7
6030         xxsave=xx
6031         xx=xx+aincr
6032         write (2,*) xx,yy,zz
6033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6034         de_dxx_num=(sumenep-sumene)/aincr
6035         xx=xxsave
6036         write (2,*) "xx+ sumene from enesc=",sumenep
6037         yysave=yy
6038         yy=yy+aincr
6039         write (2,*) xx,yy,zz
6040         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6041         de_dyy_num=(sumenep-sumene)/aincr
6042         yy=yysave
6043         write (2,*) "yy+ sumene from enesc=",sumenep
6044         zzsave=zz
6045         zz=zz+aincr
6046         write (2,*) xx,yy,zz
6047         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6048         de_dzz_num=(sumenep-sumene)/aincr
6049         zz=zzsave
6050         write (2,*) "zz+ sumene from enesc=",sumenep
6051         costsave=cost2tab(i+1)
6052         sintsave=sint2tab(i+1)
6053         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6054         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6055         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6056         de_dt_num=(sumenep-sumene)/aincr
6057         write (2,*) " t+ sumene from enesc=",sumenep
6058         cost2tab(i+1)=costsave
6059         sint2tab(i+1)=sintsave
6060 C End of diagnostics section.
6061 #endif
6062 C
6063 C Compute the gradient of esc
6064 C
6065         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6066         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6067         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6068         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6069         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6070         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6071         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6072         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6073         pom1=(sumene3*sint2tab(i+1)+sumene1)
6074      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6075         pom2=(sumene4*cost2tab(i+1)+sumene2)
6076      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6077         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6078         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6079      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6080      &  +x(40)*yy*zz
6081         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6082         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6083      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6084      &  +x(60)*yy*zz
6085         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6086      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6087      &        +(pom1+pom2)*pom_dx
6088 #ifdef DEBUG
6089         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6090 #endif
6091 C
6092         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6093         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6094      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6095      &  +x(40)*xx*zz
6096         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6097         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6098      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6099      &  +x(59)*zz**2 +x(60)*xx*zz
6100         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6101      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6102      &        +(pom1-pom2)*pom_dy
6103 #ifdef DEBUG
6104         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6105 #endif
6106 C
6107         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6108      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6109      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6110      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6111      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6112      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6113      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6114      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6115 #ifdef DEBUG
6116         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6117 #endif
6118 C
6119         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6120      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6121      &  +pom1*pom_dt1+pom2*pom_dt2
6122 #ifdef DEBUG
6123         write(2,*), "de_dt = ", de_dt,de_dt_num
6124 #endif
6125 c
6126 C
6127        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6128        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6129        cosfac2xx=cosfac2*xx
6130        sinfac2yy=sinfac2*yy
6131        do k = 1,3
6132          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6133      &      vbld_inv(i+1)
6134          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6135      &      vbld_inv(i)
6136          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6137          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6138 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6139 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6140 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6141 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6142          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6143          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6144          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6145          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6146          dZZ_Ci1(k)=0.0d0
6147          dZZ_Ci(k)=0.0d0
6148          do j=1,3
6149            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6150      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6151            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6152      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6153          enddo
6154
6155          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6156          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6157          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6158 c
6159          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6160          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6161        enddo
6162
6163        do k=1,3
6164          dXX_Ctab(k,i)=dXX_Ci(k)
6165          dXX_C1tab(k,i)=dXX_Ci1(k)
6166          dYY_Ctab(k,i)=dYY_Ci(k)
6167          dYY_C1tab(k,i)=dYY_Ci1(k)
6168          dZZ_Ctab(k,i)=dZZ_Ci(k)
6169          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6170          dXX_XYZtab(k,i)=dXX_XYZ(k)
6171          dYY_XYZtab(k,i)=dYY_XYZ(k)
6172          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6173        enddo
6174
6175        do k = 1,3
6176 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6177 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6178 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6179 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6180 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6181 c     &    dt_dci(k)
6182 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6183 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6184          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6185      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6186          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6187      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6188          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6189      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6190        enddo
6191 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6192 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6193
6194 C to check gradient call subroutine check_grad
6195
6196     1 continue
6197       enddo
6198       return
6199       end
6200 #endif
6201 c------------------------------------------------------------------------------
6202       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6203 C
6204 C This procedure calculates two-body contact function g(rij) and its derivative:
6205 C
6206 C           eps0ij                                     !       x < -1
6207 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6208 C            0                                         !       x > 1
6209 C
6210 C where x=(rij-r0ij)/delta
6211 C
6212 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6213 C
6214       implicit none
6215       double precision rij,r0ij,eps0ij,fcont,fprimcont
6216       double precision x,x2,x4,delta
6217 c     delta=0.02D0*r0ij
6218 c      delta=0.2D0*r0ij
6219       x=(rij-r0ij)/delta
6220       if (x.lt.-1.0D0) then
6221         fcont=eps0ij
6222         fprimcont=0.0D0
6223       else if (x.le.1.0D0) then
6224         x2=x*x
6225         x4=x2*x2
6226         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6227         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6228       else
6229         fcont=0.0D0
6230         fprimcont=0.0D0
6231       endif
6232       return
6233       end
6234 c------------------------------------------------------------------------------
6235       subroutine splinthet(theti,delta,ss,ssder)
6236       implicit real*8 (a-h,o-z)
6237       include 'DIMENSIONS'
6238       include 'DIMENSIONS.ZSCOPT'
6239       include 'COMMON.VAR'
6240       include 'COMMON.GEO'
6241       thetup=pi-delta
6242       thetlow=delta
6243       if (theti.gt.pipol) then
6244         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6245       else
6246         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6247         ssder=-ssder
6248       endif
6249       return
6250       end
6251 c------------------------------------------------------------------------------
6252       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6253       implicit none
6254       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6255       double precision ksi,ksi2,ksi3,a1,a2,a3
6256       a1=fprim0*delta/(f1-f0)
6257       a2=3.0d0-2.0d0*a1
6258       a3=a1-2.0d0
6259       ksi=(x-x0)/delta
6260       ksi2=ksi*ksi
6261       ksi3=ksi2*ksi
6262       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6263       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6264       return
6265       end
6266 c------------------------------------------------------------------------------
6267       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6268       implicit none
6269       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6270       double precision ksi,ksi2,ksi3,a1,a2,a3
6271       ksi=(x-x0)/delta
6272       ksi2=ksi*ksi
6273       ksi3=ksi2*ksi
6274       a1=fprim0x*delta
6275       a2=3*(f1x-f0x)-2*fprim0x*delta
6276       a3=fprim0x*delta-2*(f1x-f0x)
6277       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6278       return
6279       end
6280 C-----------------------------------------------------------------------------
6281 #ifdef CRYST_TOR
6282 C-----------------------------------------------------------------------------
6283       subroutine etor(etors,fact)
6284       implicit real*8 (a-h,o-z)
6285       include 'DIMENSIONS'
6286       include 'DIMENSIONS.ZSCOPT'
6287       include 'COMMON.VAR'
6288       include 'COMMON.GEO'
6289       include 'COMMON.LOCAL'
6290       include 'COMMON.TORSION'
6291       include 'COMMON.INTERACT'
6292       include 'COMMON.DERIV'
6293       include 'COMMON.CHAIN'
6294       include 'COMMON.NAMES'
6295       include 'COMMON.IOUNITS'
6296       include 'COMMON.FFIELD'
6297       include 'COMMON.TORCNSTR'
6298       logical lprn
6299 C Set lprn=.true. for debugging
6300       lprn=.false.
6301 c      lprn=.true.
6302       etors=0.0D0
6303       do i=iphi_start,iphi_end
6304         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6305      &      .or. itype(i).eq.ntyp1) cycle
6306         itori=itortyp(itype(i-2))
6307         itori1=itortyp(itype(i-1))
6308         phii=phi(i)
6309         gloci=0.0D0
6310 C Proline-Proline pair is a special case...
6311         if (itori.eq.3 .and. itori1.eq.3) then
6312           if (phii.gt.-dwapi3) then
6313             cosphi=dcos(3*phii)
6314             fac=1.0D0/(1.0D0-cosphi)
6315             etorsi=v1(1,3,3)*fac
6316             etorsi=etorsi+etorsi
6317             etors=etors+etorsi-v1(1,3,3)
6318             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6319           endif
6320           do j=1,3
6321             v1ij=v1(j+1,itori,itori1)
6322             v2ij=v2(j+1,itori,itori1)
6323             cosphi=dcos(j*phii)
6324             sinphi=dsin(j*phii)
6325             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6326             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6327           enddo
6328         else
6329           do j=1,nterm_old
6330             v1ij=v1(j,itori,itori1)
6331             v2ij=v2(j,itori,itori1)
6332             cosphi=dcos(j*phii)
6333             sinphi=dsin(j*phii)
6334             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6335             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6336           enddo
6337         endif
6338         if (lprn)
6339      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6340      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6341      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6342         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6343 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6344       enddo
6345       return
6346       end
6347 c------------------------------------------------------------------------------
6348 #else
6349       subroutine etor(etors,fact)
6350       implicit real*8 (a-h,o-z)
6351       include 'DIMENSIONS'
6352       include 'DIMENSIONS.ZSCOPT'
6353       include 'COMMON.VAR'
6354       include 'COMMON.GEO'
6355       include 'COMMON.LOCAL'
6356       include 'COMMON.TORSION'
6357       include 'COMMON.INTERACT'
6358       include 'COMMON.DERIV'
6359       include 'COMMON.CHAIN'
6360       include 'COMMON.NAMES'
6361       include 'COMMON.IOUNITS'
6362       include 'COMMON.FFIELD'
6363       include 'COMMON.TORCNSTR'
6364       logical lprn
6365 C Set lprn=.true. for debugging
6366       lprn=.false.
6367 c      lprn=.true.
6368       etors=0.0D0
6369       do i=iphi_start,iphi_end
6370         if (i.le.2) cycle
6371         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6372      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6373 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
6374 C     &       .or. itype(i).eq.ntyp1) cycle
6375         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6376          if (iabs(itype(i)).eq.20) then
6377          iblock=2
6378          else
6379          iblock=1
6380          endif
6381         itori=itortyp(itype(i-2))
6382         itori1=itortyp(itype(i-1))
6383         phii=phi(i)
6384         gloci=0.0D0
6385 C Regular cosine and sine terms
6386         do j=1,nterm(itori,itori1,iblock)
6387           v1ij=v1(j,itori,itori1,iblock)
6388           v2ij=v2(j,itori,itori1,iblock)
6389           cosphi=dcos(j*phii)
6390           sinphi=dsin(j*phii)
6391           etors=etors+v1ij*cosphi+v2ij*sinphi
6392           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6393         enddo
6394 C Lorentz terms
6395 C                         v1
6396 C  E = SUM ----------------------------------- - v1
6397 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6398 C
6399         cosphi=dcos(0.5d0*phii)
6400         sinphi=dsin(0.5d0*phii)
6401         do j=1,nlor(itori,itori1,iblock)
6402           vl1ij=vlor1(j,itori,itori1)
6403           vl2ij=vlor2(j,itori,itori1)
6404           vl3ij=vlor3(j,itori,itori1)
6405           pom=vl2ij*cosphi+vl3ij*sinphi
6406           pom1=1.0d0/(pom*pom+1.0d0)
6407           etors=etors+vl1ij*pom1
6408 c          if (energy_dec) etors_ii=etors_ii+
6409 c     &                vl1ij*pom1
6410           pom=-pom*pom1*pom1
6411           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6412         enddo
6413 C Subtract the constant term
6414         etors=etors-v0(itori,itori1,iblock)
6415         if (lprn)
6416      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6417      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6418      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6419         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6420 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6421  1215   continue
6422       enddo
6423       return
6424       end
6425 c----------------------------------------------------------------------------
6426       subroutine etor_d(etors_d,fact2)
6427 C 6/23/01 Compute double torsional energy
6428       implicit real*8 (a-h,o-z)
6429       include 'DIMENSIONS'
6430       include 'DIMENSIONS.ZSCOPT'
6431       include 'COMMON.VAR'
6432       include 'COMMON.GEO'
6433       include 'COMMON.LOCAL'
6434       include 'COMMON.TORSION'
6435       include 'COMMON.INTERACT'
6436       include 'COMMON.DERIV'
6437       include 'COMMON.CHAIN'
6438       include 'COMMON.NAMES'
6439       include 'COMMON.IOUNITS'
6440       include 'COMMON.FFIELD'
6441       include 'COMMON.TORCNSTR'
6442       logical lprn
6443 C Set lprn=.true. for debugging
6444       lprn=.false.
6445 c     lprn=.true.
6446       etors_d=0.0D0
6447       do i=iphi_start,iphi_end-1
6448         if (i.le.3) cycle
6449 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6450 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
6451          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6452      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6453      &  (itype(i+1).eq.ntyp1)) cycle
6454         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6455      &     goto 1215
6456         itori=itortyp(itype(i-2))
6457         itori1=itortyp(itype(i-1))
6458         itori2=itortyp(itype(i))
6459         phii=phi(i)
6460         phii1=phi(i+1)
6461         gloci1=0.0D0
6462         gloci2=0.0D0
6463         iblock=1
6464         if (iabs(itype(i+1)).eq.20) iblock=2
6465 C Regular cosine and sine terms
6466         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6467           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6468           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6469           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6470           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6471           cosphi1=dcos(j*phii)
6472           sinphi1=dsin(j*phii)
6473           cosphi2=dcos(j*phii1)
6474           sinphi2=dsin(j*phii1)
6475           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6476      &     v2cij*cosphi2+v2sij*sinphi2
6477           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6478           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6479         enddo
6480         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6481           do l=1,k-1
6482             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6483             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6484             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6485             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6486             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6487             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6488             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6489             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6490             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6491      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6492             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6493      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6494             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6495      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6496           enddo
6497         enddo
6498         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6499         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6500  1215   continue
6501       enddo
6502       return
6503       end
6504 #endif
6505 c---------------------------------------------------------------------------
6506 C The rigorous attempt to derive energy function
6507       subroutine etor_kcc(etors,fact)
6508       implicit real*8 (a-h,o-z)
6509       include 'DIMENSIONS'
6510       include 'DIMENSIONS.ZSCOPT'
6511       include 'COMMON.VAR'
6512       include 'COMMON.GEO'
6513       include 'COMMON.LOCAL'
6514       include 'COMMON.TORSION'
6515       include 'COMMON.INTERACT'
6516       include 'COMMON.DERIV'
6517       include 'COMMON.CHAIN'
6518       include 'COMMON.NAMES'
6519       include 'COMMON.IOUNITS'
6520       include 'COMMON.FFIELD'
6521       include 'COMMON.TORCNSTR'
6522       include 'COMMON.CONTROL'
6523       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6524       logical lprn
6525 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6526 C Set lprn=.true. for debugging
6527       lprn=energy_dec
6528 c     lprn=.true.
6529 C      print *,"wchodze kcc"
6530       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6531       etors=0.0D0
6532       do i=iphi_start,iphi_end
6533 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6534 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6535 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6536 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6537         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6538      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6539         itori=itortyp(itype(i-2))
6540         itori1=itortyp(itype(i-1))
6541         phii=phi(i)
6542         glocig=0.0D0
6543         glocit1=0.0d0
6544         glocit2=0.0d0
6545 C to avoid multiple devision by 2
6546 c        theti22=0.5d0*theta(i)
6547 C theta 12 is the theta_1 /2
6548 C theta 22 is theta_2 /2
6549 c        theti12=0.5d0*theta(i-1)
6550 C and appropriate sinus function
6551         sinthet1=dsin(theta(i-1))
6552         sinthet2=dsin(theta(i))
6553         costhet1=dcos(theta(i-1))
6554         costhet2=dcos(theta(i))
6555 C to speed up lets store its mutliplication
6556         sint1t2=sinthet2*sinthet1
6557         sint1t2n=1.0d0
6558 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6559 C +d_n*sin(n*gamma)) *
6560 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6561 C we have two sum 1) Non-Chebyshev which is with n and gamma
6562         nval=nterm_kcc_Tb(itori,itori1)
6563         c1(0)=0.0d0
6564         c2(0)=0.0d0
6565         c1(1)=1.0d0
6566         c2(1)=1.0d0
6567         do j=2,nval
6568           c1(j)=c1(j-1)*costhet1
6569           c2(j)=c2(j-1)*costhet2
6570         enddo
6571         etori=0.0d0
6572         do j=1,nterm_kcc(itori,itori1)
6573           cosphi=dcos(j*phii)
6574           sinphi=dsin(j*phii)
6575           sint1t2n1=sint1t2n
6576           sint1t2n=sint1t2n*sint1t2
6577           sumvalc=0.0d0
6578           gradvalct1=0.0d0
6579           gradvalct2=0.0d0
6580           do k=1,nval
6581             do l=1,nval
6582               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6583               gradvalct1=gradvalct1+
6584      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6585               gradvalct2=gradvalct2+
6586      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6587             enddo
6588           enddo
6589           gradvalct1=-gradvalct1*sinthet1
6590           gradvalct2=-gradvalct2*sinthet2
6591           sumvals=0.0d0
6592           gradvalst1=0.0d0
6593           gradvalst2=0.0d0
6594           do k=1,nval
6595             do l=1,nval
6596               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6597               gradvalst1=gradvalst1+
6598      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6599               gradvalst2=gradvalst2+
6600      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6601             enddo
6602           enddo
6603           gradvalst1=-gradvalst1*sinthet1
6604           gradvalst2=-gradvalst2*sinthet2
6605           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6606 C glocig is the gradient local i site in gamma
6607           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6608 C now gradient over theta_1
6609           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6610      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6611           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6612      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6613         enddo ! j
6614         etors=etors+etori
6615 C derivative over gamma
6616         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6617 C derivative over theta1
6618         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6619 C now derivative over theta2
6620         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6621         if (lprn) then
6622           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6623      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6624           write (iout,*) "c1",(c1(k),k=0,nval),
6625      &    " c2",(c2(k),k=0,nval)
6626           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6627         endif
6628       enddo
6629       return
6630       end
6631 c---------------------------------------------------------------------------------------------
6632       subroutine etor_constr(edihcnstr)
6633       implicit real*8 (a-h,o-z)
6634       include 'DIMENSIONS'
6635       include 'DIMENSIONS.ZSCOPT'
6636       include 'COMMON.VAR'
6637       include 'COMMON.GEO'
6638       include 'COMMON.LOCAL'
6639       include 'COMMON.TORSION'
6640       include 'COMMON.INTERACT'
6641       include 'COMMON.DERIV'
6642       include 'COMMON.CHAIN'
6643       include 'COMMON.NAMES'
6644       include 'COMMON.IOUNITS'
6645       include 'COMMON.FFIELD'
6646       include 'COMMON.TORCNSTR'
6647       include 'COMMON.CONTROL'
6648 ! 6/20/98 - dihedral angle constraints
6649       edihcnstr=0.0d0
6650 c      do i=1,ndih_constr
6651 c      write (iout,*) "idihconstr_start",idihconstr_start,
6652 c     &  " idihconstr_end",idihconstr_end
6653
6654       if (raw_psipred) then
6655         do i=idihconstr_start,idihconstr_end
6656           itori=idih_constr(i)
6657           phii=phi(itori)
6658           gaudih_i=vpsipred(1,i)
6659           gauder_i=0.0d0
6660           do j=1,2
6661             s = sdihed(j,i)
6662             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6663             dexpcos_i=dexp(-cos_i*cos_i)
6664             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6665             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6666      &            *cos_i*dexpcos_i/s**2
6667           enddo
6668           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6669           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6670           if (energy_dec)
6671      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6672      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6673      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6674      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6675      &     -wdihc*dlog(gaudih_i)
6676         enddo
6677       else
6678
6679       do i=idihconstr_start,idihconstr_end
6680         itori=idih_constr(i)
6681         phii=phi(itori)
6682         difi=pinorm(phii-phi0(i))
6683         if (difi.gt.drange(i)) then
6684           difi=difi-drange(i)
6685           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6686           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6687         else if (difi.lt.-drange(i)) then
6688           difi=difi+drange(i)
6689           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6690           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6691         else
6692           difi=0.0
6693         endif
6694       enddo
6695
6696       endif
6697
6698 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6699       return
6700       end
6701 c----------------------------------------------------------------------------
6702 C The rigorous attempt to derive energy function
6703       subroutine ebend_kcc(etheta)
6704
6705       implicit real*8 (a-h,o-z)
6706       include 'DIMENSIONS'
6707       include 'DIMENSIONS.ZSCOPT'
6708       include 'COMMON.VAR'
6709       include 'COMMON.GEO'
6710       include 'COMMON.LOCAL'
6711       include 'COMMON.TORSION'
6712       include 'COMMON.INTERACT'
6713       include 'COMMON.DERIV'
6714       include 'COMMON.CHAIN'
6715       include 'COMMON.NAMES'
6716       include 'COMMON.IOUNITS'
6717       include 'COMMON.FFIELD'
6718       include 'COMMON.TORCNSTR'
6719       include 'COMMON.CONTROL'
6720       logical lprn
6721       double precision thybt1(maxang_kcc)
6722 C Set lprn=.true. for debugging
6723       lprn=energy_dec
6724 c     lprn=.true.
6725 C      print *,"wchodze kcc"
6726       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6727       etheta=0.0D0
6728       do i=ithet_start,ithet_end
6729 c        print *,i,itype(i-1),itype(i),itype(i-2)
6730         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6731      &  .or.itype(i).eq.ntyp1) cycle
6732         iti=iabs(itortyp(itype(i-1)))
6733         sinthet=dsin(theta(i))
6734         costhet=dcos(theta(i))
6735         do j=1,nbend_kcc_Tb(iti)
6736           thybt1(j)=v1bend_chyb(j,iti)
6737         enddo
6738         sumth1thyb=v1bend_chyb(0,iti)+
6739      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6740         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6741      &    sumth1thyb
6742         ihelp=nbend_kcc_Tb(iti)-1
6743         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6744         etheta=etheta+sumth1thyb
6745 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6746         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6747       enddo
6748       return
6749       end
6750 c-------------------------------------------------------------------------------------
6751       subroutine etheta_constr(ethetacnstr)
6752
6753       implicit real*8 (a-h,o-z)
6754       include 'DIMENSIONS'
6755       include 'DIMENSIONS.ZSCOPT'
6756       include 'COMMON.VAR'
6757       include 'COMMON.GEO'
6758       include 'COMMON.LOCAL'
6759       include 'COMMON.TORSION'
6760       include 'COMMON.INTERACT'
6761       include 'COMMON.DERIV'
6762       include 'COMMON.CHAIN'
6763       include 'COMMON.NAMES'
6764       include 'COMMON.IOUNITS'
6765       include 'COMMON.FFIELD'
6766       include 'COMMON.TORCNSTR'
6767       include 'COMMON.CONTROL'
6768       ethetacnstr=0.0d0
6769 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6770       do i=ithetaconstr_start,ithetaconstr_end
6771         itheta=itheta_constr(i)
6772         thetiii=theta(itheta)
6773         difi=pinorm(thetiii-theta_constr0(i))
6774         if (difi.gt.theta_drange(i)) then
6775           difi=difi-theta_drange(i)
6776           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6777           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6778      &    +for_thet_constr(i)*difi**3
6779         else if (difi.lt.-drange(i)) then
6780           difi=difi+drange(i)
6781           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6782           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6783      &    +for_thet_constr(i)*difi**3
6784         else
6785           difi=0.0
6786         endif
6787        if (energy_dec) then
6788         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6789      &    i,itheta,rad2deg*thetiii,
6790      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6791      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6792      &    gloc(itheta+nphi-2,icg)
6793         endif
6794       enddo
6795       return
6796       end
6797 c------------------------------------------------------------------------------
6798 c------------------------------------------------------------------------------
6799       subroutine eback_sc_corr(esccor)
6800 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6801 c        conformational states; temporarily implemented as differences
6802 c        between UNRES torsional potentials (dependent on three types of
6803 c        residues) and the torsional potentials dependent on all 20 types
6804 c        of residues computed from AM1 energy surfaces of terminally-blocked
6805 c        amino-acid residues.
6806       implicit real*8 (a-h,o-z)
6807       include 'DIMENSIONS'
6808       include 'DIMENSIONS.ZSCOPT'
6809       include 'COMMON.VAR'
6810       include 'COMMON.GEO'
6811       include 'COMMON.LOCAL'
6812       include 'COMMON.TORSION'
6813       include 'COMMON.SCCOR'
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.CONTROL'
6821       logical lprn
6822 C Set lprn=.true. for debugging
6823       lprn=.false.
6824 c      lprn=.true.
6825 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6826       esccor=0.0D0
6827       do i=itau_start,itau_end
6828         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6829         esccor_ii=0.0D0
6830         isccori=isccortyp(itype(i-2))
6831         isccori1=isccortyp(itype(i-1))
6832         phii=phi(i)
6833         do intertyp=1,3 !intertyp
6834 cc Added 09 May 2012 (Adasko)
6835 cc  Intertyp means interaction type of backbone mainchain correlation:
6836 c   1 = SC...Ca...Ca...Ca
6837 c   2 = Ca...Ca...Ca...SC
6838 c   3 = SC...Ca...Ca...SCi
6839         gloci=0.0D0
6840         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6841      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6842      &      (itype(i-1).eq.ntyp1)))
6843      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6844      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6845      &     .or.(itype(i).eq.ntyp1)))
6846      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6847      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6848      &      (itype(i-3).eq.ntyp1)))) cycle
6849         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6850         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6851      & cycle
6852        do j=1,nterm_sccor(isccori,isccori1)
6853           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6854           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6855           cosphi=dcos(j*tauangle(intertyp,i))
6856           sinphi=dsin(j*tauangle(intertyp,i))
6857            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6858            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6859          enddo
6860 C      write (iout,*)"EBACK_SC_COR",esccor,i
6861 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6862 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6863 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6864         if (lprn)
6865      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6866      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6867      &  (v1sccor(j,1,itori,itori1),j=1,6)
6868      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6869 c        gsccor_loc(i-3)=gloci
6870        enddo !intertyp
6871       enddo
6872       return
6873       end
6874 #ifdef FOURBODY
6875 c------------------------------------------------------------------------------
6876       subroutine multibody(ecorr)
6877 C This subroutine calculates multi-body contributions to energy following
6878 C the idea of Skolnick et al. If side chains I and J make a contact and
6879 C at the same time side chains I+1 and J+1 make a contact, an extra
6880 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6881       implicit real*8 (a-h,o-z)
6882       include 'DIMENSIONS'
6883       include 'COMMON.IOUNITS'
6884       include 'COMMON.DERIV'
6885       include 'COMMON.INTERACT'
6886       include 'COMMON.CONTACTS'
6887       include 'COMMON.CONTMAT'
6888       include 'COMMON.CORRMAT'
6889       double precision gx(3),gx1(3)
6890       logical lprn
6891
6892 C Set lprn=.true. for debugging
6893       lprn=.false.
6894
6895       if (lprn) then
6896         write (iout,'(a)') 'Contact function values:'
6897         do i=nnt,nct-2
6898           write (iout,'(i2,20(1x,i2,f10.5))')
6899      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6900         enddo
6901       endif
6902       ecorr=0.0D0
6903       do i=nnt,nct
6904         do j=1,3
6905           gradcorr(j,i)=0.0D0
6906           gradxorr(j,i)=0.0D0
6907         enddo
6908       enddo
6909       do i=nnt,nct-2
6910
6911         DO ISHIFT = 3,4
6912
6913         i1=i+ishift
6914         num_conti=num_cont(i)
6915         num_conti1=num_cont(i1)
6916         do jj=1,num_conti
6917           j=jcont(jj,i)
6918           do kk=1,num_conti1
6919             j1=jcont(kk,i1)
6920             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6921 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6922 cd   &                   ' ishift=',ishift
6923 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6924 C The system gains extra energy.
6925               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6926             endif   ! j1==j+-ishift
6927           enddo     ! kk
6928         enddo       ! jj
6929
6930         ENDDO ! ISHIFT
6931
6932       enddo         ! i
6933       return
6934       end
6935 c------------------------------------------------------------------------------
6936       double precision function esccorr(i,j,k,l,jj,kk)
6937       implicit real*8 (a-h,o-z)
6938       include 'DIMENSIONS'
6939       include 'COMMON.IOUNITS'
6940       include 'COMMON.DERIV'
6941       include 'COMMON.INTERACT'
6942       include 'COMMON.CONTACTS'
6943       include 'COMMON.CONTMAT'
6944       include 'COMMON.CORRMAT'
6945       double precision gx(3),gx1(3)
6946       logical lprn
6947       lprn=.false.
6948       eij=facont(jj,i)
6949       ekl=facont(kk,k)
6950 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6951 C Calculate the multi-body contribution to energy.
6952 C Calculate multi-body contributions to the gradient.
6953 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6954 cd   & k,l,(gacont(m,kk,k),m=1,3)
6955       do m=1,3
6956         gx(m) =ekl*gacont(m,jj,i)
6957         gx1(m)=eij*gacont(m,kk,k)
6958         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6959         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6960         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6961         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6962       enddo
6963       do m=i,j-1
6964         do ll=1,3
6965           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6966         enddo
6967       enddo
6968       do m=k,l-1
6969         do ll=1,3
6970           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6971         enddo
6972       enddo
6973       esccorr=-eij*ekl
6974       return
6975       end
6976 c------------------------------------------------------------------------------
6977       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6978 C This subroutine calculates multi-body contributions to hydrogen-bonding
6979       implicit real*8 (a-h,o-z)
6980       include 'DIMENSIONS'
6981       include 'DIMENSIONS.ZSCOPT'
6982       include 'COMMON.IOUNITS'
6983       include 'COMMON.FFIELD'
6984       include 'COMMON.DERIV'
6985       include 'COMMON.INTERACT'
6986       include 'COMMON.CONTACTS'
6987       include 'COMMON.CONTMAT'
6988       include 'COMMON.CORRMAT'
6989       double precision gx(3),gx1(3)
6990       logical lprn,ldone
6991
6992 C Set lprn=.true. for debugging
6993       lprn=.false.
6994       if (lprn) then
6995         write (iout,'(a)') 'Contact function values:'
6996         do i=nnt,nct-2
6997           write (iout,'(2i3,50(1x,i2,f5.2))')
6998      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6999      &    j=1,num_cont_hb(i))
7000         enddo
7001       endif
7002       ecorr=0.0D0
7003 C Remove the loop below after debugging !!!
7004       do i=nnt,nct
7005         do j=1,3
7006           gradcorr(j,i)=0.0D0
7007           gradxorr(j,i)=0.0D0
7008         enddo
7009       enddo
7010 C Calculate the local-electrostatic correlation terms
7011       do i=iatel_s,iatel_e+1
7012         i1=i+1
7013         num_conti=num_cont_hb(i)
7014         num_conti1=num_cont_hb(i+1)
7015         do jj=1,num_conti
7016           j=jcont_hb(jj,i)
7017           do kk=1,num_conti1
7018             j1=jcont_hb(kk,i1)
7019 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7020 c     &         ' jj=',jj,' kk=',kk
7021             if (j1.eq.j+1 .or. j1.eq.j-1) then
7022 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7023 C The system gains extra energy.
7024               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7025               n_corr=n_corr+1
7026             else if (j1.eq.j) then
7027 C Contacts I-J and I-(J+1) occur simultaneously.
7028 C The system loses extra energy.
7029 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7030             endif
7031           enddo ! kk
7032           do kk=1,num_conti
7033             j1=jcont_hb(kk,i)
7034 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7035 c    &         ' jj=',jj,' kk=',kk
7036             if (j1.eq.j+1) then
7037 C Contacts I-J and (I+1)-J occur simultaneously.
7038 C The system loses extra energy.
7039 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7040             endif ! j1==j+1
7041           enddo ! kk
7042         enddo ! jj
7043       enddo ! i
7044       return
7045       end
7046 c------------------------------------------------------------------------------
7047       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7048      &  n_corr1)
7049 C This subroutine calculates multi-body contributions to hydrogen-bonding
7050       implicit real*8 (a-h,o-z)
7051       include 'DIMENSIONS'
7052       include 'DIMENSIONS.ZSCOPT'
7053       include 'COMMON.IOUNITS'
7054 #ifdef MPI
7055       include "mpif.h"
7056 #endif
7057       include 'COMMON.FFIELD'
7058       include 'COMMON.DERIV'
7059       include 'COMMON.LOCAL'
7060       include 'COMMON.INTERACT'
7061       include 'COMMON.CONTACTS'
7062       include 'COMMON.CONTMAT'
7063       include 'COMMON.CORRMAT'
7064       include 'COMMON.CHAIN'
7065       include 'COMMON.CONTROL'
7066       include 'COMMON.SHIELD'
7067       double precision gx(3),gx1(3)
7068       integer num_cont_hb_old(maxres)
7069       logical lprn,ldone
7070       double precision eello4,eello5,eelo6,eello_turn6
7071       external eello4,eello5,eello6,eello_turn6
7072 C Set lprn=.true. for debugging
7073       lprn=.false.
7074       eturn6=0.0d0
7075       if (lprn) then
7076         write (iout,'(a)') 'Contact function values:'
7077         do i=nnt,nct-2
7078           write (iout,'(2i3,50(1x,i2,5f6.3))')
7079      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7080      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7081         enddo
7082       endif
7083       ecorr=0.0D0
7084       ecorr5=0.0d0
7085       ecorr6=0.0d0
7086 C Remove the loop below after debugging !!!
7087       do i=nnt,nct
7088         do j=1,3
7089           gradcorr(j,i)=0.0D0
7090           gradxorr(j,i)=0.0D0
7091         enddo
7092       enddo
7093 C Calculate the dipole-dipole interaction energies
7094       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7095       do i=iatel_s,iatel_e+1
7096         num_conti=num_cont_hb(i)
7097         do jj=1,num_conti
7098           j=jcont_hb(jj,i)
7099 #ifdef MOMENT
7100           call dipole(i,j,jj)
7101 #endif
7102         enddo
7103       enddo
7104       endif
7105 C Calculate the local-electrostatic correlation terms
7106 c                write (iout,*) "gradcorr5 in eello5 before loop"
7107 c                do iii=1,nres
7108 c                  write (iout,'(i5,3f10.5)')
7109 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7110 c                enddo
7111       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7112 c        write (iout,*) "corr loop i",i
7113         i1=i+1
7114         num_conti=num_cont_hb(i)
7115         num_conti1=num_cont_hb(i+1)
7116         do jj=1,num_conti
7117           j=jcont_hb(jj,i)
7118           jp=iabs(j)
7119           do kk=1,num_conti1
7120             j1=jcont_hb(kk,i1)
7121             jp1=iabs(j1)
7122 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7123 c     &         ' jj=',jj,' kk=',kk
7124 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7125             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7126      &          .or. j.lt.0 .and. j1.gt.0) .and.
7127      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7128 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7129 C The system gains extra energy.
7130               n_corr=n_corr+1
7131               sqd1=dsqrt(d_cont(jj,i))
7132               sqd2=dsqrt(d_cont(kk,i1))
7133               sred_geom = sqd1*sqd2
7134               IF (sred_geom.lt.cutoff_corr) THEN
7135                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7136      &            ekont,fprimcont)
7137 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7138 cd     &         ' jj=',jj,' kk=',kk
7139                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7140                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7141                 do l=1,3
7142                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7143                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7144                 enddo
7145                 n_corr1=n_corr1+1
7146 cd               write (iout,*) 'sred_geom=',sred_geom,
7147 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7148 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7149 cd               write (iout,*) "g_contij",g_contij
7150 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7151 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7152                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7153                 if (wcorr4.gt.0.0d0)
7154      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7155 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7156                   if (energy_dec.and.wcorr4.gt.0.0d0)
7157      1                 write (iout,'(a6,4i5,0pf7.3)')
7158      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7159 c                write (iout,*) "gradcorr5 before eello5"
7160 c                do iii=1,nres
7161 c                  write (iout,'(i5,3f10.5)')
7162 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7163 c                enddo
7164                 if (wcorr5.gt.0.0d0)
7165      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7166 c                write (iout,*) "gradcorr5 after eello5"
7167 c                do iii=1,nres
7168 c                  write (iout,'(i5,3f10.5)')
7169 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7170 c                enddo
7171                   if (energy_dec.and.wcorr5.gt.0.0d0)
7172      1                 write (iout,'(a6,4i5,0pf7.3)')
7173      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7174 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7175 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7176                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7177      &               .or. wturn6.eq.0.0d0))then
7178 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7179                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7180                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7181      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7182 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7183 cd     &            'ecorr6=',ecorr6
7184 cd                write (iout,'(4e15.5)') sred_geom,
7185 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7186 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7187 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7188                 else if (wturn6.gt.0.0d0
7189      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7190 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7191                   eturn6=eturn6+eello_turn6(i,jj,kk)
7192                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7193      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7194 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7195                 endif
7196               ENDIF
7197 1111          continue
7198             endif
7199           enddo ! kk
7200         enddo ! jj
7201       enddo ! i
7202       do i=1,nres
7203         num_cont_hb(i)=num_cont_hb_old(i)
7204       enddo
7205 c                write (iout,*) "gradcorr5 in eello5"
7206 c                do iii=1,nres
7207 c                  write (iout,'(i5,3f10.5)')
7208 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7209 c                enddo
7210       return
7211       end
7212 c------------------------------------------------------------------------------
7213       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7214       implicit real*8 (a-h,o-z)
7215       include 'DIMENSIONS'
7216       include 'DIMENSIONS.ZSCOPT'
7217       include 'COMMON.IOUNITS'
7218       include 'COMMON.DERIV'
7219       include 'COMMON.INTERACT'
7220       include 'COMMON.CONTACTS'
7221       include 'COMMON.CONTMAT'
7222       include 'COMMON.CORRMAT'
7223       include 'COMMON.SHIELD'
7224       include 'COMMON.CONTROL'
7225       double precision gx(3),gx1(3)
7226       logical lprn
7227       lprn=.false.
7228 C      print *,"wchodze",fac_shield(i),shield_mode
7229       eij=facont_hb(jj,i)
7230       ekl=facont_hb(kk,k)
7231       ees0pij=ees0p(jj,i)
7232       ees0pkl=ees0p(kk,k)
7233       ees0mij=ees0m(jj,i)
7234       ees0mkl=ees0m(kk,k)
7235       ekont=eij*ekl
7236       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7237 C*
7238 C     & fac_shield(i)**2*fac_shield(j)**2
7239 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7240 C Following 4 lines for diagnostics.
7241 cd    ees0pkl=0.0D0
7242 cd    ees0pij=1.0D0
7243 cd    ees0mkl=0.0D0
7244 cd    ees0mij=1.0D0
7245 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7246 c     & 'Contacts ',i,j,
7247 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7248 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7249 c     & 'gradcorr_long'
7250 C Calculate the multi-body contribution to energy.
7251 C      ecorr=ecorr+ekont*ees
7252 C Calculate multi-body contributions to the gradient.
7253       coeffpees0pij=coeffp*ees0pij
7254       coeffmees0mij=coeffm*ees0mij
7255       coeffpees0pkl=coeffp*ees0pkl
7256       coeffmees0mkl=coeffm*ees0mkl
7257       do ll=1,3
7258 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7259         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7260      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7261      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7262         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7263      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7264      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7265 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7266         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7267      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7268      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7269         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7270      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7271      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7272         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7273      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7274      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7275         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7276         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7277         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7278      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7279      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7280         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7281         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7282 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7283       enddo
7284 c      write (iout,*)
7285 cgrad      do m=i+1,j-1
7286 cgrad        do ll=1,3
7287 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7288 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7289 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7290 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7291 cgrad        enddo
7292 cgrad      enddo
7293 cgrad      do m=k+1,l-1
7294 cgrad        do ll=1,3
7295 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7296 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7297 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7298 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7299 cgrad        enddo
7300 cgrad      enddo
7301 c      write (iout,*) "ehbcorr",ekont*ees
7302 C      print *,ekont,ees,i,k
7303       ehbcorr=ekont*ees
7304 C now gradient over shielding
7305 C      return
7306       if (shield_mode.gt.0) then
7307        j=ees0plist(jj,i)
7308        l=ees0plist(kk,k)
7309 C        print *,i,j,fac_shield(i),fac_shield(j),
7310 C     &fac_shield(k),fac_shield(l)
7311         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
7312      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
7313           do ilist=1,ishield_list(i)
7314            iresshield=shield_list(ilist,i)
7315            do m=1,3
7316            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
7317 C     &      *2.0
7318            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7319      &              rlocshield
7320      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
7321             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7322      &+rlocshield
7323            enddo
7324           enddo
7325           do ilist=1,ishield_list(j)
7326            iresshield=shield_list(ilist,j)
7327            do m=1,3
7328            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
7329 C     &     *2.0
7330            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7331      &              rlocshield
7332      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
7333            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7334      &     +rlocshield
7335            enddo
7336           enddo
7337
7338           do ilist=1,ishield_list(k)
7339            iresshield=shield_list(ilist,k)
7340            do m=1,3
7341            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
7342 C     &     *2.0
7343            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7344      &              rlocshield
7345      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
7346            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7347      &     +rlocshield
7348            enddo
7349           enddo
7350           do ilist=1,ishield_list(l)
7351            iresshield=shield_list(ilist,l)
7352            do m=1,3
7353            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
7354 C     &     *2.0
7355            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
7356      &              rlocshield
7357      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
7358            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
7359      &     +rlocshield
7360            enddo
7361           enddo
7362 C          print *,gshieldx(m,iresshield)
7363           do m=1,3
7364             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
7365      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7366             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
7367      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7368             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
7369      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
7370             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
7371      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
7372
7373             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
7374      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7375             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
7376      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7377             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
7378      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
7379             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
7380      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
7381
7382            enddo
7383       endif
7384       endif
7385       return
7386       end
7387 #ifdef MOMENT
7388 C---------------------------------------------------------------------------
7389       subroutine dipole(i,j,jj)
7390       implicit real*8 (a-h,o-z)
7391       include 'DIMENSIONS'
7392       include 'DIMENSIONS.ZSCOPT'
7393       include 'COMMON.IOUNITS'
7394       include 'COMMON.CHAIN'
7395       include 'COMMON.FFIELD'
7396       include 'COMMON.DERIV'
7397       include 'COMMON.INTERACT'
7398       include 'COMMON.CONTACTS'
7399       include 'COMMON.CONTMAT'
7400       include 'COMMON.CORRMAT'
7401       include 'COMMON.TORSION'
7402       include 'COMMON.VAR'
7403       include 'COMMON.GEO'
7404       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7405      &  auxmat(2,2)
7406       iti1 = itortyp(itype(i+1))
7407       if (j.lt.nres-1) then
7408         itj1 = itype2loc(itype(j+1))
7409       else
7410         itj1=nloctyp
7411       endif
7412       do iii=1,2
7413         dipi(iii,1)=Ub2(iii,i)
7414         dipderi(iii)=Ub2der(iii,i)
7415         dipi(iii,2)=b1(iii,i+1)
7416         dipj(iii,1)=Ub2(iii,j)
7417         dipderj(iii)=Ub2der(iii,j)
7418         dipj(iii,2)=b1(iii,j+1)
7419       enddo
7420       kkk=0
7421       do iii=1,2
7422         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7423         do jjj=1,2
7424           kkk=kkk+1
7425           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7426         enddo
7427       enddo
7428       do kkk=1,5
7429         do lll=1,3
7430           mmm=0
7431           do iii=1,2
7432             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7433      &        auxvec(1))
7434             do jjj=1,2
7435               mmm=mmm+1
7436               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7437             enddo
7438           enddo
7439         enddo
7440       enddo
7441       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7442       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7443       do iii=1,2
7444         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7445       enddo
7446       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7447       do iii=1,2
7448         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7449       enddo
7450       return
7451       end
7452 #endif
7453 C---------------------------------------------------------------------------
7454       subroutine calc_eello(i,j,k,l,jj,kk)
7455 C
7456 C This subroutine computes matrices and vectors needed to calculate
7457 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7458 C
7459       implicit real*8 (a-h,o-z)
7460       include 'DIMENSIONS'
7461       include 'DIMENSIONS.ZSCOPT'
7462       include 'COMMON.IOUNITS'
7463       include 'COMMON.CHAIN'
7464       include 'COMMON.DERIV'
7465       include 'COMMON.INTERACT'
7466       include 'COMMON.CONTACTS'
7467       include 'COMMON.CONTMAT'
7468       include 'COMMON.CORRMAT'
7469       include 'COMMON.TORSION'
7470       include 'COMMON.VAR'
7471       include 'COMMON.GEO'
7472       include 'COMMON.FFIELD'
7473       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7474      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7475       logical lprn
7476       common /kutas/ lprn
7477 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7478 cd     & ' jj=',jj,' kk=',kk
7479 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7480 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7481 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7482       do iii=1,2
7483         do jjj=1,2
7484           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7485           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7486         enddo
7487       enddo
7488       call transpose2(aa1(1,1),aa1t(1,1))
7489       call transpose2(aa2(1,1),aa2t(1,1))
7490       do kkk=1,5
7491         do lll=1,3
7492           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7493      &      aa1tder(1,1,lll,kkk))
7494           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7495      &      aa2tder(1,1,lll,kkk))
7496         enddo
7497       enddo
7498       if (l.eq.j+1) then
7499 C parallel orientation of the two CA-CA-CA frames.
7500         if (i.gt.1) then
7501           iti=itype2loc(itype(i))
7502         else
7503           iti=nloctyp
7504         endif
7505         itk1=itype2loc(itype(k+1))
7506         itj=itype2loc(itype(j))
7507         if (l.lt.nres-1) then
7508           itl1=itype2loc(itype(l+1))
7509         else
7510           itl1=nloctyp
7511         endif
7512 C A1 kernel(j+1) A2T
7513 cd        do iii=1,2
7514 cd          write (iout,'(3f10.5,5x,3f10.5)')
7515 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7516 cd        enddo
7517         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7518      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7519      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7520 C Following matrices are needed only for 6-th order cumulants
7521         IF (wcorr6.gt.0.0d0) THEN
7522         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7523      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7524      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7525         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7526      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7527      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7528      &   ADtEAderx(1,1,1,1,1,1))
7529         lprn=.false.
7530         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7531      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7532      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7533      &   ADtEA1derx(1,1,1,1,1,1))
7534         ENDIF
7535 C End 6-th order cumulants
7536 cd        lprn=.false.
7537 cd        if (lprn) then
7538 cd        write (2,*) 'In calc_eello6'
7539 cd        do iii=1,2
7540 cd          write (2,*) 'iii=',iii
7541 cd          do kkk=1,5
7542 cd            write (2,*) 'kkk=',kkk
7543 cd            do jjj=1,2
7544 cd              write (2,'(3(2f10.5),5x)')
7545 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7546 cd            enddo
7547 cd          enddo
7548 cd        enddo
7549 cd        endif
7550         call transpose2(EUgder(1,1,k),auxmat(1,1))
7551         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7552         call transpose2(EUg(1,1,k),auxmat(1,1))
7553         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7554         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7555         do iii=1,2
7556           do kkk=1,5
7557             do lll=1,3
7558               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7559      &          EAEAderx(1,1,lll,kkk,iii,1))
7560             enddo
7561           enddo
7562         enddo
7563 C A1T kernel(i+1) A2
7564         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7565      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7566      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7567 C Following matrices are needed only for 6-th order cumulants
7568         IF (wcorr6.gt.0.0d0) THEN
7569         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7570      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7571      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7572         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7573      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7574      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7575      &   ADtEAderx(1,1,1,1,1,2))
7576         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7577      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7578      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7579      &   ADtEA1derx(1,1,1,1,1,2))
7580         ENDIF
7581 C End 6-th order cumulants
7582         call transpose2(EUgder(1,1,l),auxmat(1,1))
7583         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7584         call transpose2(EUg(1,1,l),auxmat(1,1))
7585         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7586         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7587         do iii=1,2
7588           do kkk=1,5
7589             do lll=1,3
7590               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7591      &          EAEAderx(1,1,lll,kkk,iii,2))
7592             enddo
7593           enddo
7594         enddo
7595 C AEAb1 and AEAb2
7596 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7597 C They are needed only when the fifth- or the sixth-order cumulants are
7598 C indluded.
7599         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7600         call transpose2(AEA(1,1,1),auxmat(1,1))
7601         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7602         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7603         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7604         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7605         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7606         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7607         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7608         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7609         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7610         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7611         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7612         call transpose2(AEA(1,1,2),auxmat(1,1))
7613         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7614         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7615         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7616         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7617         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7618         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7619         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7620         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7621         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7622         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7623         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7624 C Calculate the Cartesian derivatives of the vectors.
7625         do iii=1,2
7626           do kkk=1,5
7627             do lll=1,3
7628               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7629               call matvec2(auxmat(1,1),b1(1,i),
7630      &          AEAb1derx(1,lll,kkk,iii,1,1))
7631               call matvec2(auxmat(1,1),Ub2(1,i),
7632      &          AEAb2derx(1,lll,kkk,iii,1,1))
7633               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7634      &          AEAb1derx(1,lll,kkk,iii,2,1))
7635               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7636      &          AEAb2derx(1,lll,kkk,iii,2,1))
7637               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7638               call matvec2(auxmat(1,1),b1(1,j),
7639      &          AEAb1derx(1,lll,kkk,iii,1,2))
7640               call matvec2(auxmat(1,1),Ub2(1,j),
7641      &          AEAb2derx(1,lll,kkk,iii,1,2))
7642               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7643      &          AEAb1derx(1,lll,kkk,iii,2,2))
7644               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7645      &          AEAb2derx(1,lll,kkk,iii,2,2))
7646             enddo
7647           enddo
7648         enddo
7649         ENDIF
7650 C End vectors
7651       else
7652 C Antiparallel orientation of the two CA-CA-CA frames.
7653         if (i.gt.1) then
7654           iti=itype2loc(itype(i))
7655         else
7656           iti=nloctyp
7657         endif
7658         itk1=itype2loc(itype(k+1))
7659         itl=itype2loc(itype(l))
7660         itj=itype2loc(itype(j))
7661         if (j.lt.nres-1) then
7662           itj1=itype2loc(itype(j+1))
7663         else
7664           itj1=nloctyp
7665         endif
7666 C A2 kernel(j-1)T A1T
7667         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7668      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7669      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7670 C Following matrices are needed only for 6-th order cumulants
7671         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7672      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7673         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7674      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7675      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7676         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7677      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7678      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7679      &   ADtEAderx(1,1,1,1,1,1))
7680         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7681      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7682      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7683      &   ADtEA1derx(1,1,1,1,1,1))
7684         ENDIF
7685 C End 6-th order cumulants
7686         call transpose2(EUgder(1,1,k),auxmat(1,1))
7687         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7688         call transpose2(EUg(1,1,k),auxmat(1,1))
7689         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7690         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7691         do iii=1,2
7692           do kkk=1,5
7693             do lll=1,3
7694               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7695      &          EAEAderx(1,1,lll,kkk,iii,1))
7696             enddo
7697           enddo
7698         enddo
7699 C A2T kernel(i+1)T A1
7700         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7701      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7702      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7703 C Following matrices are needed only for 6-th order cumulants
7704         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7705      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7706         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7707      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7708      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7709         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7710      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7711      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7712      &   ADtEAderx(1,1,1,1,1,2))
7713         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7714      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7715      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7716      &   ADtEA1derx(1,1,1,1,1,2))
7717         ENDIF
7718 C End 6-th order cumulants
7719         call transpose2(EUgder(1,1,j),auxmat(1,1))
7720         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7721         call transpose2(EUg(1,1,j),auxmat(1,1))
7722         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7723         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7724         do iii=1,2
7725           do kkk=1,5
7726             do lll=1,3
7727               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7728      &          EAEAderx(1,1,lll,kkk,iii,2))
7729             enddo
7730           enddo
7731         enddo
7732 C AEAb1 and AEAb2
7733 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7734 C They are needed only when the fifth- or the sixth-order cumulants are
7735 C indluded.
7736         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7737      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7738         call transpose2(AEA(1,1,1),auxmat(1,1))
7739         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7740         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7741         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7742         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7743         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7744         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7745         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7746         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7747         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7748         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7749         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7750         call transpose2(AEA(1,1,2),auxmat(1,1))
7751         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7752         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7753         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7754         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7755         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7756         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7757         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7758         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7759         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7760         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7761         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7762 C Calculate the Cartesian derivatives of the vectors.
7763         do iii=1,2
7764           do kkk=1,5
7765             do lll=1,3
7766               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7767               call matvec2(auxmat(1,1),b1(1,i),
7768      &          AEAb1derx(1,lll,kkk,iii,1,1))
7769               call matvec2(auxmat(1,1),Ub2(1,i),
7770      &          AEAb2derx(1,lll,kkk,iii,1,1))
7771               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7772      &          AEAb1derx(1,lll,kkk,iii,2,1))
7773               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7774      &          AEAb2derx(1,lll,kkk,iii,2,1))
7775               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7776               call matvec2(auxmat(1,1),b1(1,l),
7777      &          AEAb1derx(1,lll,kkk,iii,1,2))
7778               call matvec2(auxmat(1,1),Ub2(1,l),
7779      &          AEAb2derx(1,lll,kkk,iii,1,2))
7780               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7781      &          AEAb1derx(1,lll,kkk,iii,2,2))
7782               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7783      &          AEAb2derx(1,lll,kkk,iii,2,2))
7784             enddo
7785           enddo
7786         enddo
7787         ENDIF
7788 C End vectors
7789       endif
7790       return
7791       end
7792 C---------------------------------------------------------------------------
7793       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7794      &  KK,KKderg,AKA,AKAderg,AKAderx)
7795       implicit none
7796       integer nderg
7797       logical transp
7798       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7799      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7800      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7801       integer iii,kkk,lll
7802       integer jjj,mmm
7803       logical lprn
7804       common /kutas/ lprn
7805       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7806       do iii=1,nderg
7807         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7808      &    AKAderg(1,1,iii))
7809       enddo
7810 cd      if (lprn) write (2,*) 'In kernel'
7811       do kkk=1,5
7812 cd        if (lprn) write (2,*) 'kkk=',kkk
7813         do lll=1,3
7814           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7815      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7816 cd          if (lprn) then
7817 cd            write (2,*) 'lll=',lll
7818 cd            write (2,*) 'iii=1'
7819 cd            do jjj=1,2
7820 cd              write (2,'(3(2f10.5),5x)')
7821 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7822 cd            enddo
7823 cd          endif
7824           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7825      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7826 cd          if (lprn) then
7827 cd            write (2,*) 'lll=',lll
7828 cd            write (2,*) 'iii=2'
7829 cd            do jjj=1,2
7830 cd              write (2,'(3(2f10.5),5x)')
7831 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7832 cd            enddo
7833 cd          endif
7834         enddo
7835       enddo
7836       return
7837       end
7838 C---------------------------------------------------------------------------
7839       double precision function eello4(i,j,k,l,jj,kk)
7840       implicit real*8 (a-h,o-z)
7841       include 'DIMENSIONS'
7842       include 'DIMENSIONS.ZSCOPT'
7843       include 'COMMON.IOUNITS'
7844       include 'COMMON.CHAIN'
7845       include 'COMMON.DERIV'
7846       include 'COMMON.INTERACT'
7847       include 'COMMON.CONTACTS'
7848       include 'COMMON.CONTMAT'
7849       include 'COMMON.CORRMAT'
7850       include 'COMMON.TORSION'
7851       include 'COMMON.VAR'
7852       include 'COMMON.GEO'
7853       double precision pizda(2,2),ggg1(3),ggg2(3)
7854 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7855 cd        eello4=0.0d0
7856 cd        return
7857 cd      endif
7858 cd      print *,'eello4:',i,j,k,l,jj,kk
7859 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7860 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7861 cold      eij=facont_hb(jj,i)
7862 cold      ekl=facont_hb(kk,k)
7863 cold      ekont=eij*ekl
7864       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7865       if (calc_grad) then
7866 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7867       gcorr_loc(k-1)=gcorr_loc(k-1)
7868      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7869       if (l.eq.j+1) then
7870         gcorr_loc(l-1)=gcorr_loc(l-1)
7871      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7872       else
7873         gcorr_loc(j-1)=gcorr_loc(j-1)
7874      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7875       endif
7876       do iii=1,2
7877         do kkk=1,5
7878           do lll=1,3
7879             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7880      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7881 cd            derx(lll,kkk,iii)=0.0d0
7882           enddo
7883         enddo
7884       enddo
7885 cd      gcorr_loc(l-1)=0.0d0
7886 cd      gcorr_loc(j-1)=0.0d0
7887 cd      gcorr_loc(k-1)=0.0d0
7888 cd      eel4=1.0d0
7889 cd      write (iout,*)'Contacts have occurred for peptide groups',
7890 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7891 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7892       if (j.lt.nres-1) then
7893         j1=j+1
7894         j2=j-1
7895       else
7896         j1=j-1
7897         j2=j-2
7898       endif
7899       if (l.lt.nres-1) then
7900         l1=l+1
7901         l2=l-1
7902       else
7903         l1=l-1
7904         l2=l-2
7905       endif
7906       do ll=1,3
7907 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7908 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7909         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7910         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7911 cgrad        ghalf=0.5d0*ggg1(ll)
7912         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7913         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7914         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7915         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7916         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7917         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7918 cgrad        ghalf=0.5d0*ggg2(ll)
7919         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7920         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7921         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7922         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7923         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7924         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7925       enddo
7926 cgrad      do m=i+1,j-1
7927 cgrad        do ll=1,3
7928 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7929 cgrad        enddo
7930 cgrad      enddo
7931 cgrad      do m=k+1,l-1
7932 cgrad        do ll=1,3
7933 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7934 cgrad        enddo
7935 cgrad      enddo
7936 cgrad      do m=i+2,j2
7937 cgrad        do ll=1,3
7938 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7939 cgrad        enddo
7940 cgrad      enddo
7941 cgrad      do m=k+2,l2
7942 cgrad        do ll=1,3
7943 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7944 cgrad        enddo
7945 cgrad      enddo
7946 cd      do iii=1,nres-3
7947 cd        write (2,*) iii,gcorr_loc(iii)
7948 cd      enddo
7949       endif ! calc_grad
7950       eello4=ekont*eel4
7951 cd      write (2,*) 'ekont',ekont
7952 cd      write (iout,*) 'eello4',ekont*eel4
7953       return
7954       end
7955 C---------------------------------------------------------------------------
7956       double precision function eello5(i,j,k,l,jj,kk)
7957       implicit real*8 (a-h,o-z)
7958       include 'DIMENSIONS'
7959       include 'DIMENSIONS.ZSCOPT'
7960       include 'COMMON.IOUNITS'
7961       include 'COMMON.CHAIN'
7962       include 'COMMON.DERIV'
7963       include 'COMMON.INTERACT'
7964       include 'COMMON.CONTACTS'
7965       include 'COMMON.CONTMAT'
7966       include 'COMMON.CORRMAT'
7967       include 'COMMON.TORSION'
7968       include 'COMMON.VAR'
7969       include 'COMMON.GEO'
7970       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7971       double precision ggg1(3),ggg2(3)
7972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7973 C                                                                              C
7974 C                            Parallel chains                                   C
7975 C                                                                              C
7976 C          o             o                   o             o                   C
7977 C         /l\           / \             \   / \           / \   /              C
7978 C        /   \         /   \             \ /   \         /   \ /               C
7979 C       j| o |l1       | o |              o| o |         | o |o                C
7980 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7981 C      \i/   \         /   \ /             /   \         /   \                 C
7982 C       o    k1             o                                                  C
7983 C         (I)          (II)                (III)          (IV)                 C
7984 C                                                                              C
7985 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7986 C                                                                              C
7987 C                            Antiparallel chains                               C
7988 C                                                                              C
7989 C          o             o                   o             o                   C
7990 C         /j\           / \             \   / \           / \   /              C
7991 C        /   \         /   \             \ /   \         /   \ /               C
7992 C      j1| o |l        | o |              o| o |         | o |o                C
7993 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7994 C      \i/   \         /   \ /             /   \         /   \                 C
7995 C       o     k1            o                                                  C
7996 C         (I)          (II)                (III)          (IV)                 C
7997 C                                                                              C
7998 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7999 C                                                                              C
8000 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8001 C                                                                              C
8002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8003 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8004 cd        eello5=0.0d0
8005 cd        return
8006 cd      endif
8007 cd      write (iout,*)
8008 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8009 cd     &   ' and',k,l
8010       itk=itype2loc(itype(k))
8011       itl=itype2loc(itype(l))
8012       itj=itype2loc(itype(j))
8013       eello5_1=0.0d0
8014       eello5_2=0.0d0
8015       eello5_3=0.0d0
8016       eello5_4=0.0d0
8017 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8018 cd     &   eel5_3_num,eel5_4_num)
8019       do iii=1,2
8020         do kkk=1,5
8021           do lll=1,3
8022             derx(lll,kkk,iii)=0.0d0
8023           enddo
8024         enddo
8025       enddo
8026 cd      eij=facont_hb(jj,i)
8027 cd      ekl=facont_hb(kk,k)
8028 cd      ekont=eij*ekl
8029 cd      write (iout,*)'Contacts have occurred for peptide groups',
8030 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8031 cd      goto 1111
8032 C Contribution from the graph I.
8033 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8034 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8035       call transpose2(EUg(1,1,k),auxmat(1,1))
8036       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8037       vv(1)=pizda(1,1)-pizda(2,2)
8038       vv(2)=pizda(1,2)+pizda(2,1)
8039       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8040      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8041       if (calc_grad) then
8042 C Explicit gradient in virtual-dihedral angles.
8043       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8044      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8045      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8046       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8047       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8048       vv(1)=pizda(1,1)-pizda(2,2)
8049       vv(2)=pizda(1,2)+pizda(2,1)
8050       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8051      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8052      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8053       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8054       vv(1)=pizda(1,1)-pizda(2,2)
8055       vv(2)=pizda(1,2)+pizda(2,1)
8056       if (l.eq.j+1) then
8057         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8058      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8059      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8060       else
8061         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8062      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8063      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8064       endif
8065 C Cartesian gradient
8066       do iii=1,2
8067         do kkk=1,5
8068           do lll=1,3
8069             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8070      &        pizda(1,1))
8071             vv(1)=pizda(1,1)-pizda(2,2)
8072             vv(2)=pizda(1,2)+pizda(2,1)
8073             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8074      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8075      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8076           enddo
8077         enddo
8078       enddo
8079       endif ! calc_grad
8080 c      goto 1112
8081 c1111  continue
8082 C Contribution from graph II
8083       call transpose2(EE(1,1,k),auxmat(1,1))
8084       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8085       vv(1)=pizda(1,1)+pizda(2,2)
8086       vv(2)=pizda(2,1)-pizda(1,2)
8087       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8088      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8089       if (calc_grad) then
8090 C Explicit gradient in virtual-dihedral angles.
8091       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8092      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8093       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8094       vv(1)=pizda(1,1)+pizda(2,2)
8095       vv(2)=pizda(2,1)-pizda(1,2)
8096       if (l.eq.j+1) then
8097         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8098      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8099      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8100       else
8101         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8102      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8103      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8104       endif
8105 C Cartesian gradient
8106       do iii=1,2
8107         do kkk=1,5
8108           do lll=1,3
8109             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8110      &        pizda(1,1))
8111             vv(1)=pizda(1,1)+pizda(2,2)
8112             vv(2)=pizda(2,1)-pizda(1,2)
8113             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8114      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8115      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8116           enddo
8117         enddo
8118       enddo
8119       endif ! calc_grad
8120 cd      goto 1112
8121 cd1111  continue
8122       if (l.eq.j+1) then
8123 cd        goto 1110
8124 C Parallel orientation
8125 C Contribution from graph III
8126         call transpose2(EUg(1,1,l),auxmat(1,1))
8127         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8128         vv(1)=pizda(1,1)-pizda(2,2)
8129         vv(2)=pizda(1,2)+pizda(2,1)
8130         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8131      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8132         if (calc_grad) then
8133 C Explicit gradient in virtual-dihedral angles.
8134         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8135      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8136      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8137         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8138         vv(1)=pizda(1,1)-pizda(2,2)
8139         vv(2)=pizda(1,2)+pizda(2,1)
8140         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8141      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8142      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8143         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8144         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8145         vv(1)=pizda(1,1)-pizda(2,2)
8146         vv(2)=pizda(1,2)+pizda(2,1)
8147         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8148      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8149      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8150 C Cartesian gradient
8151         do iii=1,2
8152           do kkk=1,5
8153             do lll=1,3
8154               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8155      &          pizda(1,1))
8156               vv(1)=pizda(1,1)-pizda(2,2)
8157               vv(2)=pizda(1,2)+pizda(2,1)
8158               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8159      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8160      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8161             enddo
8162           enddo
8163         enddo
8164 cd        goto 1112
8165 C Contribution from graph IV
8166 cd1110    continue
8167         call transpose2(EE(1,1,l),auxmat(1,1))
8168         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8169         vv(1)=pizda(1,1)+pizda(2,2)
8170         vv(2)=pizda(2,1)-pizda(1,2)
8171         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8172      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8173 C Explicit gradient in virtual-dihedral angles.
8174         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8175      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8176         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8177         vv(1)=pizda(1,1)+pizda(2,2)
8178         vv(2)=pizda(2,1)-pizda(1,2)
8179         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8180      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8181      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8182 C Cartesian gradient
8183         do iii=1,2
8184           do kkk=1,5
8185             do lll=1,3
8186               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8187      &          pizda(1,1))
8188               vv(1)=pizda(1,1)+pizda(2,2)
8189               vv(2)=pizda(2,1)-pizda(1,2)
8190               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8191      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8192      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8193             enddo
8194           enddo
8195         enddo
8196         endif ! calc_grad
8197       else
8198 C Antiparallel orientation
8199 C Contribution from graph III
8200 c        goto 1110
8201         call transpose2(EUg(1,1,j),auxmat(1,1))
8202         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8203         vv(1)=pizda(1,1)-pizda(2,2)
8204         vv(2)=pizda(1,2)+pizda(2,1)
8205         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8206      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8207         if (calc_grad) then
8208 C Explicit gradient in virtual-dihedral angles.
8209         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8210      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8211      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8212         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8213         vv(1)=pizda(1,1)-pizda(2,2)
8214         vv(2)=pizda(1,2)+pizda(2,1)
8215         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8216      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8217      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8218         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8219         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8220         vv(1)=pizda(1,1)-pizda(2,2)
8221         vv(2)=pizda(1,2)+pizda(2,1)
8222         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8223      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8224      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8225 C Cartesian gradient
8226         do iii=1,2
8227           do kkk=1,5
8228             do lll=1,3
8229               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8230      &          pizda(1,1))
8231               vv(1)=pizda(1,1)-pizda(2,2)
8232               vv(2)=pizda(1,2)+pizda(2,1)
8233               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8234      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8235      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8236             enddo
8237           enddo
8238         enddo
8239         endif ! calc_grad
8240 cd        goto 1112
8241 C Contribution from graph IV
8242 1110    continue
8243         call transpose2(EE(1,1,j),auxmat(1,1))
8244         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8245         vv(1)=pizda(1,1)+pizda(2,2)
8246         vv(2)=pizda(2,1)-pizda(1,2)
8247         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8248      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8249         if (calc_grad) then
8250 C Explicit gradient in virtual-dihedral angles.
8251         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8252      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8253         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8254         vv(1)=pizda(1,1)+pizda(2,2)
8255         vv(2)=pizda(2,1)-pizda(1,2)
8256         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8257      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8258      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8259 C Cartesian gradient
8260         do iii=1,2
8261           do kkk=1,5
8262             do lll=1,3
8263               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8264      &          pizda(1,1))
8265               vv(1)=pizda(1,1)+pizda(2,2)
8266               vv(2)=pizda(2,1)-pizda(1,2)
8267               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8268      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8269      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8270             enddo
8271           enddo
8272         enddo
8273         endif ! calc_grad
8274       endif
8275 1112  continue
8276       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8277 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8278 cd        write (2,*) 'ijkl',i,j,k,l
8279 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8280 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8281 cd      endif
8282 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8283 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8284 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8285 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8286       if (calc_grad) then
8287       if (j.lt.nres-1) then
8288         j1=j+1
8289         j2=j-1
8290       else
8291         j1=j-1
8292         j2=j-2
8293       endif
8294       if (l.lt.nres-1) then
8295         l1=l+1
8296         l2=l-1
8297       else
8298         l1=l-1
8299         l2=l-2
8300       endif
8301 cd      eij=1.0d0
8302 cd      ekl=1.0d0
8303 cd      ekont=1.0d0
8304 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8305 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8306 C        summed up outside the subrouine as for the other subroutines
8307 C        handling long-range interactions. The old code is commented out
8308 C        with "cgrad" to keep track of changes.
8309       do ll=1,3
8310 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8311 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8312         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8313         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8314 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8315 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8316 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8317 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8318 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8319 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8320 c     &   gradcorr5ij,
8321 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8322 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8323 cgrad        ghalf=0.5d0*ggg1(ll)
8324 cd        ghalf=0.0d0
8325         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8326         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8327         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8328         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8329         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8330         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8331 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8332 cgrad        ghalf=0.5d0*ggg2(ll)
8333 cd        ghalf=0.0d0
8334         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
8335         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8336         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
8337         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8338         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8339         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8340       enddo
8341       endif ! calc_grad
8342 cd      goto 1112
8343 cgrad      do m=i+1,j-1
8344 cgrad        do ll=1,3
8345 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8346 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8347 cgrad        enddo
8348 cgrad      enddo
8349 cgrad      do m=k+1,l-1
8350 cgrad        do ll=1,3
8351 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8352 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8353 cgrad        enddo
8354 cgrad      enddo
8355 c1112  continue
8356 cgrad      do m=i+2,j2
8357 cgrad        do ll=1,3
8358 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8359 cgrad        enddo
8360 cgrad      enddo
8361 cgrad      do m=k+2,l2
8362 cgrad        do ll=1,3
8363 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8364 cgrad        enddo
8365 cgrad      enddo
8366 cd      do iii=1,nres-3
8367 cd        write (2,*) iii,g_corr5_loc(iii)
8368 cd      enddo
8369       eello5=ekont*eel5
8370 cd      write (2,*) 'ekont',ekont
8371 cd      write (iout,*) 'eello5',ekont*eel5
8372       return
8373       end
8374 c--------------------------------------------------------------------------
8375       double precision function eello6(i,j,k,l,jj,kk)
8376       implicit real*8 (a-h,o-z)
8377       include 'DIMENSIONS'
8378       include 'DIMENSIONS.ZSCOPT'
8379       include 'COMMON.IOUNITS'
8380       include 'COMMON.CHAIN'
8381       include 'COMMON.DERIV'
8382       include 'COMMON.INTERACT'
8383       include 'COMMON.CONTACTS'
8384       include 'COMMON.CONTMAT'
8385       include 'COMMON.CORRMAT'
8386       include 'COMMON.TORSION'
8387       include 'COMMON.VAR'
8388       include 'COMMON.GEO'
8389       include 'COMMON.FFIELD'
8390       double precision ggg1(3),ggg2(3)
8391 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8392 cd        eello6=0.0d0
8393 cd        return
8394 cd      endif
8395 cd      write (iout,*)
8396 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8397 cd     &   ' and',k,l
8398       eello6_1=0.0d0
8399       eello6_2=0.0d0
8400       eello6_3=0.0d0
8401       eello6_4=0.0d0
8402       eello6_5=0.0d0
8403       eello6_6=0.0d0
8404 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8405 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8406       do iii=1,2
8407         do kkk=1,5
8408           do lll=1,3
8409             derx(lll,kkk,iii)=0.0d0
8410           enddo
8411         enddo
8412       enddo
8413 cd      eij=facont_hb(jj,i)
8414 cd      ekl=facont_hb(kk,k)
8415 cd      ekont=eij*ekl
8416 cd      eij=1.0d0
8417 cd      ekl=1.0d0
8418 cd      ekont=1.0d0
8419       if (l.eq.j+1) then
8420         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8421         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8422         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8423         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8424         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8425         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8426       else
8427         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8428         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8429         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8430         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8431         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8432           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8433         else
8434           eello6_5=0.0d0
8435         endif
8436         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8437       endif
8438 C If turn contributions are considered, they will be handled separately.
8439       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8440 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8441 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8442 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8443 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8444 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8445 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8446 cd      goto 1112
8447       if (calc_grad) then
8448       if (j.lt.nres-1) then
8449         j1=j+1
8450         j2=j-1
8451       else
8452         j1=j-1
8453         j2=j-2
8454       endif
8455       if (l.lt.nres-1) then
8456         l1=l+1
8457         l2=l-1
8458       else
8459         l1=l-1
8460         l2=l-2
8461       endif
8462       do ll=1,3
8463 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8464 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8465 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8466 cgrad        ghalf=0.5d0*ggg1(ll)
8467 cd        ghalf=0.0d0
8468         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8469         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8470         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8471         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8472         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8473         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8474         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8475         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8476 cgrad        ghalf=0.5d0*ggg2(ll)
8477 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8478 cd        ghalf=0.0d0
8479         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8480         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8481         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8482         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8483         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8484         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8485       enddo
8486       endif ! calc_grad
8487 cd      goto 1112
8488 cgrad      do m=i+1,j-1
8489 cgrad        do ll=1,3
8490 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8491 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8492 cgrad        enddo
8493 cgrad      enddo
8494 cgrad      do m=k+1,l-1
8495 cgrad        do ll=1,3
8496 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8497 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8498 cgrad        enddo
8499 cgrad      enddo
8500 cgrad1112  continue
8501 cgrad      do m=i+2,j2
8502 cgrad        do ll=1,3
8503 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8504 cgrad        enddo
8505 cgrad      enddo
8506 cgrad      do m=k+2,l2
8507 cgrad        do ll=1,3
8508 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8509 cgrad        enddo
8510 cgrad      enddo
8511 cd      do iii=1,nres-3
8512 cd        write (2,*) iii,g_corr6_loc(iii)
8513 cd      enddo
8514       eello6=ekont*eel6
8515 cd      write (2,*) 'ekont',ekont
8516 cd      write (iout,*) 'eello6',ekont*eel6
8517       return
8518       end
8519 c--------------------------------------------------------------------------
8520       double precision function eello6_graph1(i,j,k,l,imat,swap)
8521       implicit real*8 (a-h,o-z)
8522       include 'DIMENSIONS'
8523       include 'DIMENSIONS.ZSCOPT'
8524       include 'COMMON.IOUNITS'
8525       include 'COMMON.CHAIN'
8526       include 'COMMON.DERIV'
8527       include 'COMMON.INTERACT'
8528       include 'COMMON.CONTACTS'
8529       include 'COMMON.CONTMAT'
8530       include 'COMMON.CORRMAT'
8531       include 'COMMON.TORSION'
8532       include 'COMMON.VAR'
8533       include 'COMMON.GEO'
8534       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8535       logical swap
8536       logical lprn
8537       common /kutas/ lprn
8538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8539 C                                                                              C
8540 C      Parallel       Antiparallel                                             C
8541 C                                                                              C
8542 C          o             o                                                     C
8543 C         /l\           /j\                                                    C
8544 C        /   \         /   \                                                   C
8545 C       /| o |         | o |\                                                  C
8546 C     \ j|/k\|  /   \  |/k\|l /                                                C
8547 C      \ /   \ /     \ /   \ /                                                 C
8548 C       o     o       o     o                                                  C
8549 C       i             i                                                        C
8550 C                                                                              C
8551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8552       itk=itype2loc(itype(k))
8553       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8554       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8555       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8556       call transpose2(EUgC(1,1,k),auxmat(1,1))
8557       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8558       vv1(1)=pizda1(1,1)-pizda1(2,2)
8559       vv1(2)=pizda1(1,2)+pizda1(2,1)
8560       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8561       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8562       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8563       s5=scalar2(vv(1),Dtobr2(1,i))
8564 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8565       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8566       if (calc_grad) then
8567       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8568      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8569      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8570      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8571      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8572      & +scalar2(vv(1),Dtobr2der(1,i)))
8573       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8574       vv1(1)=pizda1(1,1)-pizda1(2,2)
8575       vv1(2)=pizda1(1,2)+pizda1(2,1)
8576       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8577       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8578       if (l.eq.j+1) then
8579         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8580      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8581      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8582      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8583      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8584       else
8585         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8586      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8587      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8588      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8589      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8590       endif
8591       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8592       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8593       vv1(1)=pizda1(1,1)-pizda1(2,2)
8594       vv1(2)=pizda1(1,2)+pizda1(2,1)
8595       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8596      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8597      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8598      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8599       do iii=1,2
8600         if (swap) then
8601           ind=3-iii
8602         else
8603           ind=iii
8604         endif
8605         do kkk=1,5
8606           do lll=1,3
8607             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8608             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8609             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8610             call transpose2(EUgC(1,1,k),auxmat(1,1))
8611             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8612      &        pizda1(1,1))
8613             vv1(1)=pizda1(1,1)-pizda1(2,2)
8614             vv1(2)=pizda1(1,2)+pizda1(2,1)
8615             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8616             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8617      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8618             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8619      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8620             s5=scalar2(vv(1),Dtobr2(1,i))
8621             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8622           enddo
8623         enddo
8624       enddo
8625       endif ! calc_grad
8626       return
8627       end
8628 c----------------------------------------------------------------------------
8629       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8630       implicit real*8 (a-h,o-z)
8631       include 'DIMENSIONS'
8632       include 'DIMENSIONS.ZSCOPT'
8633       include 'COMMON.IOUNITS'
8634       include 'COMMON.CHAIN'
8635       include 'COMMON.DERIV'
8636       include 'COMMON.INTERACT'
8637       include 'COMMON.CONTACTS'
8638       include 'COMMON.CONTMAT'
8639       include 'COMMON.CORRMAT'
8640       include 'COMMON.TORSION'
8641       include 'COMMON.VAR'
8642       include 'COMMON.GEO'
8643       logical swap
8644       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8645      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8646       logical lprn
8647       common /kutas/ lprn
8648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8649 C                                                                              C
8650 C      Parallel       Antiparallel                                             C
8651 C                                                                              C
8652 C          o             o                                                     C
8653 C     \   /l\           /j\   /                                                C
8654 C      \ /   \         /   \ /                                                 C
8655 C       o| o |         | o |o                                                  C
8656 C     \ j|/k\|      \  |/k\|l                                                  C
8657 C      \ /   \       \ /   \                                                   C
8658 C       o             o                                                        C
8659 C       i             i                                                        C
8660 C                                                                              C
8661 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8662 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8663 C AL 7/4/01 s1 would occur in the sixth-order moment,
8664 C           but not in a cluster cumulant
8665 #ifdef MOMENT
8666       s1=dip(1,jj,i)*dip(1,kk,k)
8667 #endif
8668       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8669       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8670       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8671       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8672       call transpose2(EUg(1,1,k),auxmat(1,1))
8673       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8674       vv(1)=pizda(1,1)-pizda(2,2)
8675       vv(2)=pizda(1,2)+pizda(2,1)
8676       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8677 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8678 #ifdef MOMENT
8679       eello6_graph2=-(s1+s2+s3+s4)
8680 #else
8681       eello6_graph2=-(s2+s3+s4)
8682 #endif
8683 c      eello6_graph2=-s3
8684 C Derivatives in gamma(i-1)
8685       if (calc_grad) then
8686       if (i.gt.1) then
8687 #ifdef MOMENT
8688         s1=dipderg(1,jj,i)*dip(1,kk,k)
8689 #endif
8690         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8691         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8692         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8693         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8694 #ifdef MOMENT
8695         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8696 #else
8697         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8698 #endif
8699 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8700       endif
8701 C Derivatives in gamma(k-1)
8702 #ifdef MOMENT
8703       s1=dip(1,jj,i)*dipderg(1,kk,k)
8704 #endif
8705       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8706       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8707       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8708       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8709       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8710       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8711       vv(1)=pizda(1,1)-pizda(2,2)
8712       vv(2)=pizda(1,2)+pizda(2,1)
8713       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8714 #ifdef MOMENT
8715       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8716 #else
8717       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8718 #endif
8719 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8720 C Derivatives in gamma(j-1) or gamma(l-1)
8721       if (j.gt.1) then
8722 #ifdef MOMENT
8723         s1=dipderg(3,jj,i)*dip(1,kk,k)
8724 #endif
8725         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8726         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8727         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8728         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8729         vv(1)=pizda(1,1)-pizda(2,2)
8730         vv(2)=pizda(1,2)+pizda(2,1)
8731         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8732 #ifdef MOMENT
8733         if (swap) then
8734           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8735         else
8736           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8737         endif
8738 #endif
8739         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8740 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8741       endif
8742 C Derivatives in gamma(l-1) or gamma(j-1)
8743       if (l.gt.1) then
8744 #ifdef MOMENT
8745         s1=dip(1,jj,i)*dipderg(3,kk,k)
8746 #endif
8747         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8748         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8749         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8750         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8751         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8752         vv(1)=pizda(1,1)-pizda(2,2)
8753         vv(2)=pizda(1,2)+pizda(2,1)
8754         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8755 #ifdef MOMENT
8756         if (swap) then
8757           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8758         else
8759           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8760         endif
8761 #endif
8762         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8763 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8764       endif
8765 C Cartesian derivatives.
8766       if (lprn) then
8767         write (2,*) 'In eello6_graph2'
8768         do iii=1,2
8769           write (2,*) 'iii=',iii
8770           do kkk=1,5
8771             write (2,*) 'kkk=',kkk
8772             do jjj=1,2
8773               write (2,'(3(2f10.5),5x)')
8774      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8775             enddo
8776           enddo
8777         enddo
8778       endif
8779       do iii=1,2
8780         do kkk=1,5
8781           do lll=1,3
8782 #ifdef MOMENT
8783             if (iii.eq.1) then
8784               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8785             else
8786               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8787             endif
8788 #endif
8789             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8790      &        auxvec(1))
8791             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8792             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8793      &        auxvec(1))
8794             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8795             call transpose2(EUg(1,1,k),auxmat(1,1))
8796             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8797      &        pizda(1,1))
8798             vv(1)=pizda(1,1)-pizda(2,2)
8799             vv(2)=pizda(1,2)+pizda(2,1)
8800             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8801 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8802 #ifdef MOMENT
8803             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8804 #else
8805             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8806 #endif
8807             if (swap) then
8808               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8809             else
8810               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8811             endif
8812           enddo
8813         enddo
8814       enddo
8815       endif ! calc_grad
8816       return
8817       end
8818 c----------------------------------------------------------------------------
8819       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8820       implicit real*8 (a-h,o-z)
8821       include 'DIMENSIONS'
8822       include 'DIMENSIONS.ZSCOPT'
8823       include 'COMMON.IOUNITS'
8824       include 'COMMON.CHAIN'
8825       include 'COMMON.DERIV'
8826       include 'COMMON.INTERACT'
8827       include 'COMMON.CONTACTS'
8828       include 'COMMON.CONTMAT'
8829       include 'COMMON.CORRMAT'
8830       include 'COMMON.TORSION'
8831       include 'COMMON.VAR'
8832       include 'COMMON.GEO'
8833       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8834       logical swap
8835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8836 C                                                                              C
8837 C      Parallel       Antiparallel                                             C
8838 C                                                                              C
8839 C          o             o                                                     C
8840 C         /l\   /   \   /j\                                                    C
8841 C        /   \ /     \ /   \                                                   C
8842 C       /| o |o       o| o |\                                                  C
8843 C       j|/k\|  /      |/k\|l /                                                C
8844 C        /   \ /       /   \ /                                                 C
8845 C       /     o       /     o                                                  C
8846 C       i             i                                                        C
8847 C                                                                              C
8848 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8849 C
8850 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8851 C           energy moment and not to the cluster cumulant.
8852       iti=itortyp(itype(i))
8853       if (j.lt.nres-1) then
8854         itj1=itype2loc(itype(j+1))
8855       else
8856         itj1=nloctyp
8857       endif
8858       itk=itype2loc(itype(k))
8859       itk1=itype2loc(itype(k+1))
8860       if (l.lt.nres-1) then
8861         itl1=itype2loc(itype(l+1))
8862       else
8863         itl1=nloctyp
8864       endif
8865 #ifdef MOMENT
8866       s1=dip(4,jj,i)*dip(4,kk,k)
8867 #endif
8868       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8869       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8870       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8871       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8872       call transpose2(EE(1,1,k),auxmat(1,1))
8873       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8874       vv(1)=pizda(1,1)+pizda(2,2)
8875       vv(2)=pizda(2,1)-pizda(1,2)
8876       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8877 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8878 cd     & "sum",-(s2+s3+s4)
8879 #ifdef MOMENT
8880       eello6_graph3=-(s1+s2+s3+s4)
8881 #else
8882       eello6_graph3=-(s2+s3+s4)
8883 #endif
8884 c      eello6_graph3=-s4
8885 C Derivatives in gamma(k-1)
8886       if (calc_grad) then
8887       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8888       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8889       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8890       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8891 C Derivatives in gamma(l-1)
8892       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8893       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8894       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8895       vv(1)=pizda(1,1)+pizda(2,2)
8896       vv(2)=pizda(2,1)-pizda(1,2)
8897       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8898       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8899 C Cartesian derivatives.
8900       do iii=1,2
8901         do kkk=1,5
8902           do lll=1,3
8903 #ifdef MOMENT
8904             if (iii.eq.1) then
8905               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8906             else
8907               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8908             endif
8909 #endif
8910             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8911      &        auxvec(1))
8912             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8913             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8914      &        auxvec(1))
8915             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8916             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8917      &        pizda(1,1))
8918             vv(1)=pizda(1,1)+pizda(2,2)
8919             vv(2)=pizda(2,1)-pizda(1,2)
8920             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8921 #ifdef MOMENT
8922             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8923 #else
8924             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8925 #endif
8926             if (swap) then
8927               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8928             else
8929               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8930             endif
8931 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8932           enddo
8933         enddo
8934       enddo
8935       endif ! calc_grad
8936       return
8937       end
8938 c----------------------------------------------------------------------------
8939       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8940       implicit real*8 (a-h,o-z)
8941       include 'DIMENSIONS'
8942       include 'DIMENSIONS.ZSCOPT'
8943       include 'COMMON.IOUNITS'
8944       include 'COMMON.CHAIN'
8945       include 'COMMON.DERIV'
8946       include 'COMMON.INTERACT'
8947       include 'COMMON.CONTACTS'
8948       include 'COMMON.CONTMAT'
8949       include 'COMMON.CORRMAT'
8950       include 'COMMON.TORSION'
8951       include 'COMMON.VAR'
8952       include 'COMMON.GEO'
8953       include 'COMMON.FFIELD'
8954       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8955      & auxvec1(2),auxmat1(2,2)
8956       logical swap
8957 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8958 C                                                                              C
8959 C      Parallel       Antiparallel                                             C
8960 C                                                                              C
8961 C          o             o                                                     C
8962 C         /l\   /   \   /j\                                                    C
8963 C        /   \ /     \ /   \                                                   C
8964 C       /| o |o       o| o |\                                                  C
8965 C     \ j|/k\|      \  |/k\|l                                                  C
8966 C      \ /   \       \ /   \                                                   C
8967 C       o     \       o     \                                                  C
8968 C       i             i                                                        C
8969 C                                                                              C
8970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8971 C
8972 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8973 C           energy moment and not to the cluster cumulant.
8974 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8975       iti=itype2loc(itype(i))
8976       itj=itype2loc(itype(j))
8977       if (j.lt.nres-1) then
8978         itj1=itype2loc(itype(j+1))
8979       else
8980         itj1=nloctyp
8981       endif
8982       itk=itype2loc(itype(k))
8983       if (k.lt.nres-1) then
8984         itk1=itype2loc(itype(k+1))
8985       else
8986         itk1=nloctyp
8987       endif
8988       itl=itype2loc(itype(l))
8989       if (l.lt.nres-1) then
8990         itl1=itype2loc(itype(l+1))
8991       else
8992         itl1=nloctyp
8993       endif
8994 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8995 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8996 cd     & ' itl',itl,' itl1',itl1
8997 #ifdef MOMENT
8998       if (imat.eq.1) then
8999         s1=dip(3,jj,i)*dip(3,kk,k)
9000       else
9001         s1=dip(2,jj,j)*dip(2,kk,l)
9002       endif
9003 #endif
9004       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9005       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9006       if (j.eq.l+1) then
9007         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9008         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9009       else
9010         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9011         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9012       endif
9013       call transpose2(EUg(1,1,k),auxmat(1,1))
9014       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9015       vv(1)=pizda(1,1)-pizda(2,2)
9016       vv(2)=pizda(2,1)+pizda(1,2)
9017       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9018 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9019 #ifdef MOMENT
9020       eello6_graph4=-(s1+s2+s3+s4)
9021 #else
9022       eello6_graph4=-(s2+s3+s4)
9023 #endif
9024 C Derivatives in gamma(i-1)
9025       if (calc_grad) then
9026       if (i.gt.1) then
9027 #ifdef MOMENT
9028         if (imat.eq.1) then
9029           s1=dipderg(2,jj,i)*dip(3,kk,k)
9030         else
9031           s1=dipderg(4,jj,j)*dip(2,kk,l)
9032         endif
9033 #endif
9034         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9035         if (j.eq.l+1) then
9036           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9037           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9038         else
9039           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9040           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9041         endif
9042         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9043         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9044 cd          write (2,*) 'turn6 derivatives'
9045 #ifdef MOMENT
9046           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9047 #else
9048           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9049 #endif
9050         else
9051 #ifdef MOMENT
9052           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9053 #else
9054           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9055 #endif
9056         endif
9057       endif
9058 C Derivatives in gamma(k-1)
9059 #ifdef MOMENT
9060       if (imat.eq.1) then
9061         s1=dip(3,jj,i)*dipderg(2,kk,k)
9062       else
9063         s1=dip(2,jj,j)*dipderg(4,kk,l)
9064       endif
9065 #endif
9066       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9067       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9068       if (j.eq.l+1) then
9069         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9070         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9071       else
9072         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9073         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9074       endif
9075       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9076       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9077       vv(1)=pizda(1,1)-pizda(2,2)
9078       vv(2)=pizda(2,1)+pizda(1,2)
9079       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9080       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9081 #ifdef MOMENT
9082         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9083 #else
9084         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9085 #endif
9086       else
9087 #ifdef MOMENT
9088         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9089 #else
9090         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9091 #endif
9092       endif
9093 C Derivatives in gamma(j-1) or gamma(l-1)
9094       if (l.eq.j+1 .and. l.gt.1) then
9095         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9096         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9097         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9098         vv(1)=pizda(1,1)-pizda(2,2)
9099         vv(2)=pizda(2,1)+pizda(1,2)
9100         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9101         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9102       else if (j.gt.1) then
9103         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9104         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9105         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9106         vv(1)=pizda(1,1)-pizda(2,2)
9107         vv(2)=pizda(2,1)+pizda(1,2)
9108         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9109         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9110           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9111         else
9112           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9113         endif
9114       endif
9115 C Cartesian derivatives.
9116       do iii=1,2
9117         do kkk=1,5
9118           do lll=1,3
9119 #ifdef MOMENT
9120             if (iii.eq.1) then
9121               if (imat.eq.1) then
9122                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9123               else
9124                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9125               endif
9126             else
9127               if (imat.eq.1) then
9128                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9129               else
9130                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9131               endif
9132             endif
9133 #endif
9134             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9135      &        auxvec(1))
9136             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9137             if (j.eq.l+1) then
9138               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9139      &          b1(1,j+1),auxvec(1))
9140               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9141             else
9142               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9143      &          b1(1,l+1),auxvec(1))
9144               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9145             endif
9146             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9147      &        pizda(1,1))
9148             vv(1)=pizda(1,1)-pizda(2,2)
9149             vv(2)=pizda(2,1)+pizda(1,2)
9150             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9151             if (swap) then
9152               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9153 #ifdef MOMENT
9154                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9155      &             -(s1+s2+s4)
9156 #else
9157                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9158      &             -(s2+s4)
9159 #endif
9160                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9161               else
9162 #ifdef MOMENT
9163                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9164 #else
9165                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9166 #endif
9167                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9168               endif
9169             else
9170 #ifdef MOMENT
9171               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9172 #else
9173               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9174 #endif
9175               if (l.eq.j+1) then
9176                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9177               else
9178                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9179               endif
9180             endif
9181           enddo
9182         enddo
9183       enddo
9184       endif ! calc_grad
9185       return
9186       end
9187 c----------------------------------------------------------------------------
9188       double precision function eello_turn6(i,jj,kk)
9189       implicit real*8 (a-h,o-z)
9190       include 'DIMENSIONS'
9191       include 'DIMENSIONS.ZSCOPT'
9192       include 'COMMON.IOUNITS'
9193       include 'COMMON.CHAIN'
9194       include 'COMMON.DERIV'
9195       include 'COMMON.INTERACT'
9196       include 'COMMON.CONTACTS'
9197       include 'COMMON.CONTMAT'
9198       include 'COMMON.CORRMAT'
9199       include 'COMMON.TORSION'
9200       include 'COMMON.VAR'
9201       include 'COMMON.GEO'
9202       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9203      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9204      &  ggg1(3),ggg2(3)
9205       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9206      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9207 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9208 C           the respective energy moment and not to the cluster cumulant.
9209       s1=0.0d0
9210       s8=0.0d0
9211       s13=0.0d0
9212 c
9213       eello_turn6=0.0d0
9214       j=i+4
9215       k=i+1
9216       l=i+3
9217       iti=itype2loc(itype(i))
9218       itk=itype2loc(itype(k))
9219       itk1=itype2loc(itype(k+1))
9220       itl=itype2loc(itype(l))
9221       itj=itype2loc(itype(j))
9222 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9223 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9224 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9225 cd        eello6=0.0d0
9226 cd        return
9227 cd      endif
9228 cd      write (iout,*)
9229 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9230 cd     &   ' and',k,l
9231 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9232       do iii=1,2
9233         do kkk=1,5
9234           do lll=1,3
9235             derx_turn(lll,kkk,iii)=0.0d0
9236           enddo
9237         enddo
9238       enddo
9239 cd      eij=1.0d0
9240 cd      ekl=1.0d0
9241 cd      ekont=1.0d0
9242       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9243 cd      eello6_5=0.0d0
9244 cd      write (2,*) 'eello6_5',eello6_5
9245 #ifdef MOMENT
9246       call transpose2(AEA(1,1,1),auxmat(1,1))
9247       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9248       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9249       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9250 #endif
9251       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9252       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9253       s2 = scalar2(b1(1,k),vtemp1(1))
9254 #ifdef MOMENT
9255       call transpose2(AEA(1,1,2),atemp(1,1))
9256       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9257       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
9258       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9259 #endif
9260       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9261       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9262       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9263 #ifdef MOMENT
9264       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9265       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9266       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9267       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9268       ss13 = scalar2(b1(1,k),vtemp4(1))
9269       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9270 #endif
9271 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9272 c      s1=0.0d0
9273 c      s2=0.0d0
9274 c      s8=0.0d0
9275 c      s12=0.0d0
9276 c      s13=0.0d0
9277       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9278 C Derivatives in gamma(i+2)
9279       if (calc_grad) then
9280       s1d =0.0d0
9281       s8d =0.0d0
9282 #ifdef MOMENT
9283       call transpose2(AEA(1,1,1),auxmatd(1,1))
9284       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9285       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9286       call transpose2(AEAderg(1,1,2),atempd(1,1))
9287       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9288       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9289 #endif
9290       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9291       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9292       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9293 c      s1d=0.0d0
9294 c      s2d=0.0d0
9295 c      s8d=0.0d0
9296 c      s12d=0.0d0
9297 c      s13d=0.0d0
9298       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9299 C Derivatives in gamma(i+3)
9300 #ifdef MOMENT
9301       call transpose2(AEA(1,1,1),auxmatd(1,1))
9302       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9303       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9304       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9305 #endif
9306       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9307       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9308       s2d = scalar2(b1(1,k),vtemp1d(1))
9309 #ifdef MOMENT
9310       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
9311       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
9312 #endif
9313       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9314 #ifdef MOMENT
9315       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9316       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9317       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9318 #endif
9319 c      s1d=0.0d0
9320 c      s2d=0.0d0
9321 c      s8d=0.0d0
9322 c      s12d=0.0d0
9323 c      s13d=0.0d0
9324 #ifdef MOMENT
9325       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9326      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9327 #else
9328       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9329      &               -0.5d0*ekont*(s2d+s12d)
9330 #endif
9331 C Derivatives in gamma(i+4)
9332       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9333       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9334       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9335 #ifdef MOMENT
9336       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9337       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9338       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9339 #endif
9340 c      s1d=0.0d0
9341 c      s2d=0.0d0
9342 c      s8d=0.0d0
9343 C      s12d=0.0d0
9344 c      s13d=0.0d0
9345 #ifdef MOMENT
9346       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9347 #else
9348       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9349 #endif
9350 C Derivatives in gamma(i+5)
9351 #ifdef MOMENT
9352       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9353       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9354       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9355 #endif
9356       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9357       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9358       s2d = scalar2(b1(1,k),vtemp1d(1))
9359 #ifdef MOMENT
9360       call transpose2(AEA(1,1,2),atempd(1,1))
9361       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9362       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
9363 #endif
9364       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9365       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9366 #ifdef MOMENT
9367       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9368       ss13d = scalar2(b1(1,k),vtemp4d(1))
9369       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9370 #endif
9371 c      s1d=0.0d0
9372 c      s2d=0.0d0
9373 c      s8d=0.0d0
9374 c      s12d=0.0d0
9375 c      s13d=0.0d0
9376 #ifdef MOMENT
9377       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9378      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9379 #else
9380       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9381      &               -0.5d0*ekont*(s2d+s12d)
9382 #endif
9383 C Cartesian derivatives
9384       do iii=1,2
9385         do kkk=1,5
9386           do lll=1,3
9387 #ifdef MOMENT
9388             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9389             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9390             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9391 #endif
9392             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9393             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9394      &          vtemp1d(1))
9395             s2d = scalar2(b1(1,k),vtemp1d(1))
9396 #ifdef MOMENT
9397             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9398             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9399             s8d = -(atempd(1,1)+atempd(2,2))*
9400      &           scalar2(cc(1,1,l),vtemp2(1))
9401 #endif
9402             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9403      &           auxmatd(1,1))
9404             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9405             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9406 c      s1d=0.0d0
9407 c      s2d=0.0d0
9408 c      s8d=0.0d0
9409 c      s12d=0.0d0
9410 c      s13d=0.0d0
9411 #ifdef MOMENT
9412             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9413      &        - 0.5d0*(s1d+s2d)
9414 #else
9415             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9416      &        - 0.5d0*s2d
9417 #endif
9418 #ifdef MOMENT
9419             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9420      &        - 0.5d0*(s8d+s12d)
9421 #else
9422             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9423      &        - 0.5d0*s12d
9424 #endif
9425           enddo
9426         enddo
9427       enddo
9428 #ifdef MOMENT
9429       do kkk=1,5
9430         do lll=1,3
9431           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9432      &      achuj_tempd(1,1))
9433           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9434           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9435           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9436           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9437           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9438      &      vtemp4d(1))
9439           ss13d = scalar2(b1(1,k),vtemp4d(1))
9440           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9441           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9442         enddo
9443       enddo
9444 #endif
9445 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9446 cd     &  16*eel_turn6_num
9447 cd      goto 1112
9448       if (j.lt.nres-1) then
9449         j1=j+1
9450         j2=j-1
9451       else
9452         j1=j-1
9453         j2=j-2
9454       endif
9455       if (l.lt.nres-1) then
9456         l1=l+1
9457         l2=l-1
9458       else
9459         l1=l-1
9460         l2=l-2
9461       endif
9462       do ll=1,3
9463 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9464 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9465 cgrad        ghalf=0.5d0*ggg1(ll)
9466 cd        ghalf=0.0d0
9467         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9468         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9469         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9470      &    +ekont*derx_turn(ll,2,1)
9471         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9472         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9473      &    +ekont*derx_turn(ll,4,1)
9474         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9475         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9476         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9477 cgrad        ghalf=0.5d0*ggg2(ll)
9478 cd        ghalf=0.0d0
9479         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9480      &    +ekont*derx_turn(ll,2,2)
9481         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9482         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9483      &    +ekont*derx_turn(ll,4,2)
9484         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9485         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9486         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9487       enddo
9488 cd      goto 1112
9489 cgrad      do m=i+1,j-1
9490 cgrad        do ll=1,3
9491 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9492 cgrad        enddo
9493 cgrad      enddo
9494 cgrad      do m=k+1,l-1
9495 cgrad        do ll=1,3
9496 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9497 cgrad        enddo
9498 cgrad      enddo
9499 cgrad1112  continue
9500 cgrad      do m=i+2,j2
9501 cgrad        do ll=1,3
9502 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9503 cgrad        enddo
9504 cgrad      enddo
9505 cgrad      do m=k+2,l2
9506 cgrad        do ll=1,3
9507 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9508 cgrad        enddo
9509 cgrad      enddo
9510 cd      do iii=1,nres-3
9511 cd        write (2,*) iii,g_corr6_loc(iii)
9512 cd      enddo
9513       endif ! calc_grad
9514       eello_turn6=ekont*eel_turn6
9515 cd      write (2,*) 'ekont',ekont
9516 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9517       return
9518       end
9519 #endif
9520 crc-------------------------------------------------
9521 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9522       subroutine Eliptransfer(eliptran)
9523       implicit real*8 (a-h,o-z)
9524       include 'DIMENSIONS'
9525       include 'DIMENSIONS.ZSCOPT'
9526       include 'COMMON.GEO'
9527       include 'COMMON.VAR'
9528       include 'COMMON.LOCAL'
9529       include 'COMMON.CHAIN'
9530       include 'COMMON.DERIV'
9531       include 'COMMON.INTERACT'
9532       include 'COMMON.IOUNITS'
9533       include 'COMMON.CALC'
9534       include 'COMMON.CONTROL'
9535       include 'COMMON.SPLITELE'
9536       include 'COMMON.SBRIDGE'
9537 C this is done by Adasko
9538 C      print *,"wchodze"
9539 C structure of box:
9540 C      water
9541 C--bordliptop-- buffore starts
9542 C--bufliptop--- here true lipid starts
9543 C      lipid
9544 C--buflipbot--- lipid ends buffore starts
9545 C--bordlipbot--buffore ends
9546 c      call cartprint
9547 c      write (iout,*) "Eliptransfer peplipran",pepliptran
9548       eliptran=0.0
9549       do i=1,nres
9550 C       do i=1,1
9551         if (itype(i).eq.ntyp1) cycle
9552
9553         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9554         if (positi.le.0) positi=positi+boxzsize
9555 C        print *,i
9556 C first for peptide groups
9557 c for each residue check if it is in lipid or lipid water border area
9558        if ((positi.gt.bordlipbot)
9559      &.and.(positi.lt.bordliptop)) then
9560 C the energy transfer exist
9561         if (positi.lt.buflipbot) then
9562 C what fraction I am in
9563          fracinbuf=1.0d0-
9564      &        ((positi-bordlipbot)/lipbufthick)
9565 C lipbufthick is thickenes of lipid buffore
9566          sslip=sscalelip(fracinbuf)
9567          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9568          eliptran=eliptran+sslip*pepliptran
9569          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9570          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9571 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9572         elseif (positi.gt.bufliptop) then
9573          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9574          sslip=sscalelip(fracinbuf)
9575          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9576          eliptran=eliptran+sslip*pepliptran
9577          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9578          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9579 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9580 C          print *, "doing sscalefor top part"
9581 C         print *,i,sslip,fracinbuf,ssgradlip
9582         else
9583          eliptran=eliptran+pepliptran
9584 C         print *,"I am in true lipid"
9585         endif
9586 C       else
9587 C       eliptran=elpitran+0.0 ! I am in water
9588        endif
9589        enddo
9590 C       print *, "nic nie bylo w lipidzie?"
9591 C now multiply all by the peptide group transfer factor
9592 C       eliptran=eliptran*pepliptran
9593 C now the same for side chains
9594 CV       do i=1,1
9595        do i=1,nres
9596         if (itype(i).eq.ntyp1) cycle
9597         positi=(mod(c(3,i+nres),boxzsize))
9598         if (positi.le.0) positi=positi+boxzsize
9599 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
9600 c     &   bordliptop
9601 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9602 c for each residue check if it is in lipid or lipid water border area
9603 C       respos=mod(c(3,i+nres),boxzsize)
9604 C       print *,positi,bordlipbot,buflipbot
9605        if ((positi.gt.bordlipbot)
9606      & .and.(positi.lt.bordliptop)) then
9607 C the energy transfer exist
9608         if (positi.lt.buflipbot) then
9609          fracinbuf=1.0d0-
9610      &     ((positi-bordlipbot)/lipbufthick)
9611 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
9612 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
9613 C lipbufthick is thickenes of lipid buffore
9614          sslip=sscalelip(fracinbuf)
9615 c         write (iout,*) "sslip",sslip
9616          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9617          eliptran=eliptran+sslip*liptranene(itype(i))
9618          gliptranx(3,i)=gliptranx(3,i)
9619      &+ssgradlip*liptranene(itype(i))
9620          gliptranc(3,i-1)= gliptranc(3,i-1)
9621      &+ssgradlip*liptranene(itype(i))
9622 C         print *,"doing sccale for lower part"
9623         elseif (positi.gt.bufliptop) then
9624          fracinbuf=1.0d0-
9625      &((bordliptop-positi)/lipbufthick)
9626          sslip=sscalelip(fracinbuf)
9627          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9628          eliptran=eliptran+sslip*liptranene(itype(i))
9629          gliptranx(3,i)=gliptranx(3,i)
9630      &+ssgradlip*liptranene(itype(i))
9631          gliptranc(3,i-1)= gliptranc(3,i-1)
9632      &+ssgradlip*liptranene(itype(i))
9633 C          print *, "doing sscalefor top part",sslip,fracinbuf
9634         else
9635          eliptran=eliptran+liptranene(itype(i))
9636 C         print *,"I am in true lipid"
9637         endif
9638         endif ! if in lipid or buffor
9639 C       else
9640 C       eliptran=elpitran+0.0 ! I am in water
9641 c        write (iout,*) "eliptran",eliptran
9642        enddo
9643        return
9644        end
9645
9646
9647 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9648
9649       SUBROUTINE MATVEC2(A1,V1,V2)
9650       implicit real*8 (a-h,o-z)
9651       include 'DIMENSIONS'
9652       DIMENSION A1(2,2),V1(2),V2(2)
9653 c      DO 1 I=1,2
9654 c        VI=0.0
9655 c        DO 3 K=1,2
9656 c    3     VI=VI+A1(I,K)*V1(K)
9657 c        Vaux(I)=VI
9658 c    1 CONTINUE
9659
9660       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9661       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9662
9663       v2(1)=vaux1
9664       v2(2)=vaux2
9665       END
9666 C---------------------------------------
9667       SUBROUTINE MATMAT2(A1,A2,A3)
9668       implicit real*8 (a-h,o-z)
9669       include 'DIMENSIONS'
9670       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9671 c      DIMENSION AI3(2,2)
9672 c        DO  J=1,2
9673 c          A3IJ=0.0
9674 c          DO K=1,2
9675 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9676 c          enddo
9677 c          A3(I,J)=A3IJ
9678 c       enddo
9679 c      enddo
9680
9681       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9682       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9683       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9684       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9685
9686       A3(1,1)=AI3_11
9687       A3(2,1)=AI3_21
9688       A3(1,2)=AI3_12
9689       A3(2,2)=AI3_22
9690       END
9691
9692 c-------------------------------------------------------------------------
9693       double precision function scalar2(u,v)
9694       implicit none
9695       double precision u(2),v(2)
9696       double precision sc
9697       integer i
9698       scalar2=u(1)*v(1)+u(2)*v(2)
9699       return
9700       end
9701
9702 C-----------------------------------------------------------------------------
9703
9704       subroutine transpose2(a,at)
9705       implicit none
9706       double precision a(2,2),at(2,2)
9707       at(1,1)=a(1,1)
9708       at(1,2)=a(2,1)
9709       at(2,1)=a(1,2)
9710       at(2,2)=a(2,2)
9711       return
9712       end
9713 c--------------------------------------------------------------------------
9714       subroutine transpose(n,a,at)
9715       implicit none
9716       integer n,i,j
9717       double precision a(n,n),at(n,n)
9718       do i=1,n
9719         do j=1,n
9720           at(j,i)=a(i,j)
9721         enddo
9722       enddo
9723       return
9724       end
9725 C---------------------------------------------------------------------------
9726       subroutine prodmat3(a1,a2,kk,transp,prod)
9727       implicit none
9728       integer i,j
9729       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9730       logical transp
9731 crc      double precision auxmat(2,2),prod_(2,2)
9732
9733       if (transp) then
9734 crc        call transpose2(kk(1,1),auxmat(1,1))
9735 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9736 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9737
9738            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9739      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9740            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9741      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9742            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9743      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9744            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9745      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9746
9747       else
9748 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9749 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9750
9751            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9752      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9753            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9754      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9755            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9756      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9757            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9758      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9759
9760       endif
9761 c      call transpose2(a2(1,1),a2t(1,1))
9762
9763 crc      print *,transp
9764 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9765 crc      print *,((prod(i,j),i=1,2),j=1,2)
9766
9767       return
9768       end
9769 C-----------------------------------------------------------------------------
9770       double precision function scalar(u,v)
9771       implicit none
9772       double precision u(3),v(3)
9773       double precision sc
9774       integer i
9775       sc=0.0d0
9776       do i=1,3
9777         sc=sc+u(i)*v(i)
9778       enddo
9779       scalar=sc
9780       return
9781       end
9782 C-----------------------------------------------------------------------
9783       double precision function sscale(r)
9784       double precision r,gamm
9785       include "COMMON.SPLITELE"
9786       if(r.lt.r_cut-rlamb) then
9787         sscale=1.0d0
9788       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9789         gamm=(r-(r_cut-rlamb))/rlamb
9790         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9791       else
9792         sscale=0d0
9793       endif
9794       return
9795       end
9796 C-----------------------------------------------------------------------
9797 C-----------------------------------------------------------------------
9798       double precision function sscagrad(r)
9799       double precision r,gamm
9800       include "COMMON.SPLITELE"
9801       if(r.lt.r_cut-rlamb) then
9802         sscagrad=0.0d0
9803       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9804         gamm=(r-(r_cut-rlamb))/rlamb
9805         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9806       else
9807         sscagrad=0.0d0
9808       endif
9809       return
9810       end
9811 C-----------------------------------------------------------------------
9812 C-----------------------------------------------------------------------
9813       double precision function sscalelip(r)
9814       double precision r,gamm
9815       include "COMMON.SPLITELE"
9816 C      if(r.lt.r_cut-rlamb) then
9817 C        sscale=1.0d0
9818 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9819 C        gamm=(r-(r_cut-rlamb))/rlamb
9820         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9821 C      else
9822 C        sscale=0d0
9823 C      endif
9824       return
9825       end
9826 C-----------------------------------------------------------------------
9827       double precision function sscagradlip(r)
9828       double precision r,gamm
9829       include "COMMON.SPLITELE"
9830 C     if(r.lt.r_cut-rlamb) then
9831 C        sscagrad=0.0d0
9832 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9833 C        gamm=(r-(r_cut-rlamb))/rlamb
9834         sscagradlip=r*(6*r-6.0d0)
9835 C      else
9836 C        sscagrad=0.0d0
9837 C      endif
9838       return
9839       end
9840
9841 C-----------------------------------------------------------------------
9842        subroutine set_shield_fac
9843       implicit real*8 (a-h,o-z)
9844       include 'DIMENSIONS'
9845       include 'DIMENSIONS.ZSCOPT'
9846       include 'COMMON.CHAIN'
9847       include 'COMMON.DERIV'
9848       include 'COMMON.IOUNITS'
9849       include 'COMMON.SHIELD'
9850       include 'COMMON.INTERACT'
9851 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9852       double precision div77_81/0.974996043d0/,
9853      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9854
9855 C the vector between center of side_chain and peptide group
9856        double precision pep_side(3),long,side_calf(3),
9857      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9858      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9859 C the line belowe needs to be changed for FGPROC>1
9860       do i=1,nres-1
9861       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9862       ishield_list(i)=0
9863 Cif there two consequtive dummy atoms there is no peptide group between them
9864 C the line below has to be changed for FGPROC>1
9865       VolumeTotal=0.0
9866       do k=1,nres
9867        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9868        dist_pep_side=0.0
9869        dist_side_calf=0.0
9870        do j=1,3
9871 C first lets set vector conecting the ithe side-chain with kth side-chain
9872       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9873 C      pep_side(j)=2.0d0
9874 C and vector conecting the side-chain with its proper calfa
9875       side_calf(j)=c(j,k+nres)-c(j,k)
9876 C      side_calf(j)=2.0d0
9877       pept_group(j)=c(j,i)-c(j,i+1)
9878 C lets have their lenght
9879       dist_pep_side=pep_side(j)**2+dist_pep_side
9880       dist_side_calf=dist_side_calf+side_calf(j)**2
9881       dist_pept_group=dist_pept_group+pept_group(j)**2
9882       enddo
9883        dist_pep_side=dsqrt(dist_pep_side)
9884        dist_pept_group=dsqrt(dist_pept_group)
9885        dist_side_calf=dsqrt(dist_side_calf)
9886       do j=1,3
9887         pep_side_norm(j)=pep_side(j)/dist_pep_side
9888         side_calf_norm(j)=dist_side_calf
9889       enddo
9890 C now sscale fraction
9891        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9892 C       print *,buff_shield,"buff"
9893 C now sscale
9894         if (sh_frac_dist.le.0.0) cycle
9895 C If we reach here it means that this side chain reaches the shielding sphere
9896 C Lets add him to the list for gradient
9897         ishield_list(i)=ishield_list(i)+1
9898 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9899 C this list is essential otherwise problem would be O3
9900         shield_list(ishield_list(i),i)=k
9901 C Lets have the sscale value
9902         if (sh_frac_dist.gt.1.0) then
9903          scale_fac_dist=1.0d0
9904          do j=1,3
9905          sh_frac_dist_grad(j)=0.0d0
9906          enddo
9907         else
9908          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9909      &                   *(2.0*sh_frac_dist-3.0d0)
9910          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9911      &                  /dist_pep_side/buff_shield*0.5
9912 C remember for the final gradient multiply sh_frac_dist_grad(j)
9913 C for side_chain by factor -2 !
9914          do j=1,3
9915          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9916 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9917 C     &                    sh_frac_dist_grad(j)
9918          enddo
9919         endif
9920 C        if ((i.eq.3).and.(k.eq.2)) then
9921 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9922 C     & ,"TU"
9923 C        endif
9924
9925 C this is what is now we have the distance scaling now volume...
9926       short=short_r_sidechain(itype(k))
9927       long=long_r_sidechain(itype(k))
9928       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9929 C now costhet_grad
9930 C       costhet=0.0d0
9931        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9932 C       costhet_fac=0.0d0
9933        do j=1,3
9934          costhet_grad(j)=costhet_fac*pep_side(j)
9935        enddo
9936 C remember for the final gradient multiply costhet_grad(j)
9937 C for side_chain by factor -2 !
9938 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9939 C pep_side0pept_group is vector multiplication
9940       pep_side0pept_group=0.0
9941       do j=1,3
9942       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9943       enddo
9944       cosalfa=(pep_side0pept_group/
9945      & (dist_pep_side*dist_side_calf))
9946       fac_alfa_sin=1.0-cosalfa**2
9947       fac_alfa_sin=dsqrt(fac_alfa_sin)
9948       rkprim=fac_alfa_sin*(long-short)+short
9949 C now costhet_grad
9950        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9951        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9952
9953        do j=1,3
9954          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9955      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9956      &*(long-short)/fac_alfa_sin*cosalfa/
9957      &((dist_pep_side*dist_side_calf))*
9958      &((side_calf(j))-cosalfa*
9959      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9960
9961         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9962      &*(long-short)/fac_alfa_sin*cosalfa
9963      &/((dist_pep_side*dist_side_calf))*
9964      &(pep_side(j)-
9965      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9966        enddo
9967
9968       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9969      &                    /VSolvSphere_div
9970      &                    *wshield
9971 C now the gradient...
9972 C grad_shield is gradient of Calfa for peptide groups
9973 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9974 C     &               costhet,cosphi
9975 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9976 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9977       do j=1,3
9978       grad_shield(j,i)=grad_shield(j,i)
9979 C gradient po skalowaniu
9980      &                +(sh_frac_dist_grad(j)
9981 C  gradient po costhet
9982      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9983      &-scale_fac_dist*(cosphi_grad_long(j))
9984      &/(1.0-cosphi) )*div77_81
9985      &*VofOverlap
9986 C grad_shield_side is Cbeta sidechain gradient
9987       grad_shield_side(j,ishield_list(i),i)=
9988      &        (sh_frac_dist_grad(j)*(-2.0d0)
9989      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9990      &       +scale_fac_dist*(cosphi_grad_long(j))
9991      &        *2.0d0/(1.0-cosphi))
9992      &        *div77_81*VofOverlap
9993
9994        grad_shield_loc(j,ishield_list(i),i)=
9995      &   scale_fac_dist*cosphi_grad_loc(j)
9996      &        *2.0d0/(1.0-cosphi)
9997      &        *div77_81*VofOverlap
9998       enddo
9999       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10000       enddo
10001       fac_shield(i)=VolumeTotal*div77_81+div4_81
10002 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10003       enddo
10004       return
10005       end
10006 C--------------------------------------------------------------------------
10007 C first for shielding is setting of function of side-chains
10008        subroutine set_shield_fac2
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.0d0*sh_frac_dist-3.0d0)
10076          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10077      &                  /dist_pep_side/buff_shield*0.5d0
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         sh_frac_dist_grad(j)=0.0d0
10083 C         scale_fac_dist=1.0d0
10084 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10085 C     &                    sh_frac_dist_grad(j)
10086          enddo
10087         endif
10088 C this is what is now we have the distance scaling now volume...
10089       short=short_r_sidechain(itype(k))
10090       long=long_r_sidechain(itype(k))
10091       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10092       sinthet=short/dist_pep_side*costhet
10093 C now costhet_grad
10094 C       costhet=0.6d0
10095 C       sinthet=0.8
10096        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10097 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10098 C     &             -short/dist_pep_side**2/costhet)
10099 C       costhet_fac=0.0d0
10100        do j=1,3
10101          costhet_grad(j)=costhet_fac*pep_side(j)
10102        enddo
10103 C remember for the final gradient multiply costhet_grad(j)
10104 C for side_chain by factor -2 !
10105 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10106 C pep_side0pept_group is vector multiplication
10107       pep_side0pept_group=0.0d0
10108       do j=1,3
10109       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10110       enddo
10111       cosalfa=(pep_side0pept_group/
10112      & (dist_pep_side*dist_side_calf))
10113       fac_alfa_sin=1.0d0-cosalfa**2
10114       fac_alfa_sin=dsqrt(fac_alfa_sin)
10115       rkprim=fac_alfa_sin*(long-short)+short
10116 C      rkprim=short
10117
10118 C now costhet_grad
10119        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10120 C       cosphi=0.6
10121        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10122        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10123      &      dist_pep_side**2)
10124 C       sinphi=0.8
10125        do j=1,3
10126          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10127      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10128      &*(long-short)/fac_alfa_sin*cosalfa/
10129      &((dist_pep_side*dist_side_calf))*
10130      &((side_calf(j))-cosalfa*
10131      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10132 C       cosphi_grad_long(j)=0.0d0
10133         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10134      &*(long-short)/fac_alfa_sin*cosalfa
10135      &/((dist_pep_side*dist_side_calf))*
10136      &(pep_side(j)-
10137      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10138 C       cosphi_grad_loc(j)=0.0d0
10139        enddo
10140 C      print *,sinphi,sinthet
10141       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10142      &                    /VSolvSphere_div
10143 C     &                    *wshield
10144 C now the gradient...
10145       do j=1,3
10146       grad_shield(j,i)=grad_shield(j,i)
10147 C gradient po skalowaniu
10148      &                +(sh_frac_dist_grad(j)*VofOverlap
10149 C  gradient po costhet
10150      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10151      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10152      &       sinphi/sinthet*costhet*costhet_grad(j)
10153      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10154      & )*wshield
10155 C grad_shield_side is Cbeta sidechain gradient
10156       grad_shield_side(j,ishield_list(i),i)=
10157      &        (sh_frac_dist_grad(j)*(-2.0d0)
10158      &        *VofOverlap
10159      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10160      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10161      &       sinphi/sinthet*costhet*costhet_grad(j)
10162      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10163      &       )*wshield
10164
10165        grad_shield_loc(j,ishield_list(i),i)=
10166      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10167      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10168      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10169      &        ))
10170      &        *wshield
10171       enddo
10172       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10173       enddo
10174       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10175 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
10176 c     &  " wshield",wshield
10177 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10178       enddo
10179       return
10180       end
10181 C--------------------------------------------------------------------------
10182       double precision function tschebyshev(m,n,x,y)
10183       implicit none
10184       include "DIMENSIONS"
10185       integer i,m,n
10186       double precision x(n),y,yy(0:maxvar),aux
10187 c Tschebyshev polynomial. Note that the first term is omitted
10188 c m=0: the constant term is included
10189 c m=1: the constant term is not included
10190       yy(0)=1.0d0
10191       yy(1)=y
10192       do i=2,n
10193         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10194       enddo
10195       aux=0.0d0
10196       do i=m,n
10197         aux=aux+x(i)*yy(i)
10198       enddo
10199       tschebyshev=aux
10200       return
10201       end
10202 C--------------------------------------------------------------------------
10203       double precision function gradtschebyshev(m,n,x,y)
10204       implicit none
10205       include "DIMENSIONS"
10206       integer i,m,n
10207       double precision x(n+1),y,yy(0:maxvar),aux
10208 c Tschebyshev polynomial. Note that the first term is omitted
10209 c m=0: the constant term is included
10210 c m=1: the constant term is not included
10211       yy(0)=1.0d0
10212       yy(1)=2.0d0*y
10213       do i=2,n
10214         yy(i)=2*y*yy(i-1)-yy(i-2)
10215       enddo
10216       aux=0.0d0
10217       do i=m,n
10218         aux=aux+x(i+1)*yy(i)*(i+1)
10219 C        print *, x(i+1),yy(i),i
10220       enddo
10221       gradtschebyshev=aux
10222       return
10223       end
10224 c----------------------------------------------------------------------------
10225       double precision function sscale2(r,r_cut,r0,rlamb)
10226       implicit none
10227       double precision r,gamm,r_cut,r0,rlamb,rr
10228       rr = dabs(r-r0)
10229 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
10230 c      write (2,*) "rr",rr
10231       if(rr.lt.r_cut-rlamb) then
10232         sscale2=1.0d0
10233       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10234         gamm=(rr-(r_cut-rlamb))/rlamb
10235         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10236       else
10237         sscale2=0d0
10238       endif
10239       return
10240       end
10241 C-----------------------------------------------------------------------
10242       double precision function sscalgrad2(r,r_cut,r0,rlamb)
10243       implicit none
10244       double precision r,gamm,r_cut,r0,rlamb,rr
10245       rr = dabs(r-r0)
10246       if(rr.lt.r_cut-rlamb) then
10247         sscalgrad2=0.0d0
10248       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
10249         gamm=(rr-(r_cut-rlamb))/rlamb
10250         if (r.ge.r0) then
10251           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
10252         else
10253           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
10254         endif
10255       else
10256         sscalgrad2=0.0d0
10257       endif
10258       return
10259       end
10260 c----------------------------------------------------------------------------
10261       subroutine e_saxs(Esaxs_constr)
10262       implicit none
10263       include 'DIMENSIONS'
10264       include 'DIMENSIONS.ZSCOPT'
10265       include 'DIMENSIONS.FREE'
10266 #ifdef MPI
10267       include "mpif.h"
10268       include "COMMON.SETUP"
10269       integer IERR
10270 #endif
10271       include 'COMMON.SBRIDGE'
10272       include 'COMMON.CHAIN'
10273       include 'COMMON.GEO'
10274       include 'COMMON.LOCAL'
10275       include 'COMMON.INTERACT'
10276       include 'COMMON.VAR'
10277       include 'COMMON.IOUNITS'
10278       include 'COMMON.DERIV'
10279       include 'COMMON.CONTROL'
10280       include 'COMMON.NAMES'
10281       include 'COMMON.FFIELD'
10282       include 'COMMON.LANGEVIN'
10283       include 'COMMON.SAXS'
10284 c
10285       double precision Esaxs_constr
10286       integer i,iint,j,k,l
10287       double precision PgradC(maxSAXS,3,maxres),
10288      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
10289 #ifdef MPI
10290       double precision PgradC_(maxSAXS,3,maxres),
10291      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
10292 #endif
10293       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
10294      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
10295      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
10296      & auxX,auxX1,CACAgrad,Cnorm
10297       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
10298       double precision dist
10299       external dist
10300 c  SAXS restraint penalty function
10301 #ifdef DEBUG
10302       write(iout,*) "------- SAXS penalty function start -------"
10303       write (iout,*) "nsaxs",nsaxs
10304       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
10305       write (iout,*) "Psaxs"
10306       do i=1,nsaxs
10307         write (iout,'(i5,e15.5)') i, Psaxs(i)
10308       enddo
10309 #endif
10310       Esaxs_constr = 0.0d0
10311       do k=1,nsaxs
10312         Pcalc(k)=0.0d0
10313         do j=1,nres
10314           do l=1,3
10315             PgradC(k,l,j)=0.0d0
10316             PgradX(k,l,j)=0.0d0
10317           enddo
10318         enddo
10319       enddo
10320       do i=iatsc_s,iatsc_e
10321        if (itype(i).eq.ntyp1) cycle
10322        do iint=1,nint_gr(i)
10323          do j=istart(i,iint),iend(i,iint)
10324            if (itype(j).eq.ntyp1) cycle
10325 #ifdef ALLSAXS
10326            dijCACA=dist(i,j)
10327            dijCASC=dist(i,j+nres)
10328            dijSCCA=dist(i+nres,j)
10329            dijSCSC=dist(i+nres,j+nres)
10330            sigma2CACA=2.0d0/(pstok**2)
10331            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
10332            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
10333            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
10334            do k=1,nsaxs
10335              dk = distsaxs(k)
10336              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10337              if (itype(j).ne.10) then
10338              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
10339              else
10340              endif
10341              expCASC = 0.0d0
10342              if (itype(i).ne.10) then
10343              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
10344              else
10345              expSCCA = 0.0d0
10346              endif
10347              if (itype(i).ne.10 .and. itype(j).ne.10) then
10348              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
10349              else
10350              expSCSC = 0.0d0
10351              endif
10352              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
10353 #ifdef DEBUG
10354              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10355 #endif
10356              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10357              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
10358              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
10359              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
10360              do l=1,3
10361 c CA CA
10362                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10363                PgradC(k,l,i) = PgradC(k,l,i)-aux
10364                PgradC(k,l,j) = PgradC(k,l,j)+aux
10365 c CA SC
10366                if (itype(j).ne.10) then
10367                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
10368                PgradC(k,l,i) = PgradC(k,l,i)-aux
10369                PgradC(k,l,j) = PgradC(k,l,j)+aux
10370                PgradX(k,l,j) = PgradX(k,l,j)+aux
10371                endif
10372 c SC CA
10373                if (itype(i).ne.10) then
10374                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
10375                PgradX(k,l,i) = PgradX(k,l,i)-aux
10376                PgradC(k,l,i) = PgradC(k,l,i)-aux
10377                PgradC(k,l,j) = PgradC(k,l,j)+aux
10378                endif
10379 c SC SC
10380                if (itype(i).ne.10 .and. itype(j).ne.10) then
10381                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
10382                PgradC(k,l,i) = PgradC(k,l,i)-aux
10383                PgradC(k,l,j) = PgradC(k,l,j)+aux
10384                PgradX(k,l,i) = PgradX(k,l,i)-aux
10385                PgradX(k,l,j) = PgradX(k,l,j)+aux
10386                endif
10387              enddo ! l
10388            enddo ! k
10389 #else
10390            dijCACA=dist(i,j)
10391            sigma2CACA=scal_rad**2*0.25d0/
10392      &        (restok(itype(j))**2+restok(itype(i))**2)
10393
10394            IF (saxs_cutoff.eq.0) THEN
10395            do k=1,nsaxs
10396              dk = distsaxs(k)
10397              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
10398              Pcalc(k) = Pcalc(k)+expCACA
10399              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
10400              do l=1,3
10401                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10402                PgradC(k,l,i) = PgradC(k,l,i)-aux
10403                PgradC(k,l,j) = PgradC(k,l,j)+aux
10404              enddo ! l
10405            enddo ! k
10406            ELSE
10407            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
10408            do k=1,nsaxs
10409              dk = distsaxs(k)
10410 c             write (2,*) "ijk",i,j,k
10411              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
10412              if (sss2.eq.0.0d0) cycle
10413              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
10414              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
10415              Pcalc(k) = Pcalc(k)+expCACA
10416 #ifdef DEBUG
10417              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
10418 #endif
10419              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
10420      &             ssgrad2*expCACA/sss2
10421              do l=1,3
10422 c CA CA
10423                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
10424                PgradC(k,l,i) = PgradC(k,l,i)+aux
10425                PgradC(k,l,j) = PgradC(k,l,j)-aux
10426              enddo ! l
10427            enddo ! k
10428            ENDIF
10429 #endif
10430          enddo ! j
10431        enddo ! iint
10432       enddo ! i
10433 #ifdef MPI
10434       if (nfgtasks.gt.1) then
10435         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
10436      &    MPI_SUM,king,FG_COMM,IERR)
10437         if (fg_rank.eq.king) then
10438           do k=1,nsaxs
10439             Pcalc(k) = Pcalc_(k)
10440           enddo
10441         endif
10442         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
10443      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10444         if (fg_rank.eq.king) then
10445           do i=1,nres
10446             do l=1,3
10447               do k=1,nsaxs
10448                 PgradC(k,l,i) = PgradC_(k,l,i)
10449               enddo
10450             enddo
10451           enddo
10452         endif
10453 #ifdef ALLSAXS
10454         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
10455      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10456         if (fg_rank.eq.king) then
10457           do i=1,nres
10458             do l=1,3
10459               do k=1,nsaxs
10460                 PgradX(k,l,i) = PgradX_(k,l,i)
10461               enddo
10462             enddo
10463           enddo
10464         endif
10465 #endif
10466       endif
10467 #endif
10468 #ifdef MPI
10469       if (fg_rank.eq.king) then
10470 #endif
10471       Cnorm = 0.0d0
10472       do k=1,nsaxs
10473         Cnorm = Cnorm + Pcalc(k)
10474       enddo
10475       Esaxs_constr = dlog(Cnorm)-wsaxs0
10476       do k=1,nsaxs
10477         if (Pcalc(k).gt.0.0d0)
10478      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
10479 #ifdef DEBUG
10480         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
10481 #endif
10482       enddo
10483 #ifdef DEBUG
10484       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
10485 #endif
10486       do i=nnt,nct
10487         do l=1,3
10488           auxC=0.0d0
10489           auxC1=0.0d0
10490           auxX=0.0d0
10491           auxX1=0.d0
10492           do k=1,nsaxs
10493             if (Pcalc(k).gt.0)
10494      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
10495             auxC1 = auxC1+PgradC(k,l,i)
10496 #ifdef ALLSAXS
10497             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
10498             auxX1 = auxX1+PgradX(k,l,i)
10499 #endif
10500           enddo
10501           gsaxsC(l,i) = auxC - auxC1/Cnorm
10502 #ifdef ALLSAXS
10503           gsaxsX(l,i) = auxX - auxX1/Cnorm
10504 #endif
10505 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10506 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10507         enddo
10508       enddo
10509 #ifdef MPI
10510       endif
10511 #endif
10512       return
10513       end
10514 c----------------------------------------------------------------------------
10515       subroutine e_saxsC(Esaxs_constr)
10516       implicit none
10517       include 'DIMENSIONS'
10518       include 'DIMENSIONS.ZSCOPT'
10519       include 'DIMENSIONS.FREE'
10520 #ifdef MPI
10521       include "mpif.h"
10522       include "COMMON.SETUP"
10523       integer IERR
10524 #endif
10525       include 'COMMON.SBRIDGE'
10526       include 'COMMON.CHAIN'
10527       include 'COMMON.GEO'
10528       include 'COMMON.LOCAL'
10529       include 'COMMON.INTERACT'
10530       include 'COMMON.VAR'
10531       include 'COMMON.IOUNITS'
10532       include 'COMMON.DERIV'
10533       include 'COMMON.CONTROL'
10534       include 'COMMON.NAMES'
10535       include 'COMMON.FFIELD'
10536       include 'COMMON.LANGEVIN'
10537       include 'COMMON.SAXS'
10538 c
10539       double precision Esaxs_constr
10540       integer i,iint,j,k,l
10541       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
10542 #ifdef MPI
10543       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10544 #endif
10545       double precision dk,dijCASPH,dijSCSPH,
10546      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10547      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10548      & auxX,auxX1,Cnorm
10549 c  SAXS restraint penalty function
10550 #ifdef DEBUG
10551       write(iout,*) "------- SAXS penalty function start -------"
10552       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10553      & " isaxs_end",isaxs_end
10554       write (iout,*) "nnt",nnt," ntc",nct
10555       do i=nnt,nct
10556         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10557      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10558       enddo
10559       do i=nnt,nct
10560         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10561       enddo
10562 #endif
10563       Esaxs_constr = 0.0d0
10564       logPtot=0.0d0
10565       do j=isaxs_start,isaxs_end
10566         Pcalc=0.0d0
10567         do i=1,nres
10568           do l=1,3
10569             PgradC(l,i)=0.0d0
10570             PgradX(l,i)=0.0d0
10571           enddo
10572         enddo
10573         do i=nnt,nct
10574           dijCASPH=0.0d0
10575           dijSCSPH=0.0d0
10576           do l=1,3
10577             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10578           enddo
10579           if (itype(i).ne.10) then
10580           do l=1,3
10581             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10582           enddo
10583           endif
10584           sigma2CA=2.0d0/pstok**2
10585           sigma2SC=4.0d0/restok(itype(i))**2
10586           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10587           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10588           Pcalc = Pcalc+expCASPH+expSCSPH
10589 #ifdef DEBUG
10590           write(*,*) "processor i j Pcalc",
10591      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10592 #endif
10593           CASPHgrad = sigma2CA*expCASPH
10594           SCSPHgrad = sigma2SC*expSCSPH
10595           do l=1,3
10596             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10597             PgradX(l,i) = PgradX(l,i) + aux
10598             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10599           enddo ! l
10600         enddo ! i
10601         do i=nnt,nct
10602           do l=1,3
10603             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10604             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10605           enddo
10606         enddo
10607         logPtot = logPtot - dlog(Pcalc)
10608 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10609 c     &    " logPtot",logPtot
10610       enddo ! j
10611 #ifdef MPI
10612       if (nfgtasks.gt.1) then
10613 c        write (iout,*) "logPtot before reduction",logPtot
10614         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10615      &    MPI_SUM,king,FG_COMM,IERR)
10616         logPtot = logPtot_
10617 c        write (iout,*) "logPtot after reduction",logPtot
10618         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10619      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10620         if (fg_rank.eq.king) then
10621           do i=1,nres
10622             do l=1,3
10623               gsaxsC(l,i) = gsaxsC_(l,i)
10624             enddo
10625           enddo
10626         endif
10627         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10628      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10629         if (fg_rank.eq.king) then
10630           do i=1,nres
10631             do l=1,3
10632               gsaxsX(l,i) = gsaxsX_(l,i)
10633             enddo
10634           enddo
10635         endif
10636       endif
10637 #endif
10638       Esaxs_constr = logPtot
10639       return
10640       end
10641