source/cluster/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
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11
  12       include 'COMMON.IOUNITS'
  13       double precision energia(0:max_ene),energia1(0:max_ene+1)
  14       include 'COMMON.FFIELD'
  15       include 'COMMON.DERIV'
  16       include 'COMMON.INTERACT'
  17       include 'COMMON.SBRIDGE'
  18       include 'COMMON.CHAIN'
  19       include 'COMMON.SHIELD'
  20       include 'COMMON.CONTROL'
  21       include 'COMMON.TORCNSTR'
  22       include 'COMMON.SAXS'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C
  47 C Calculate electrostatic (H-bonding) energy of the main chain.
  48 C
  49   106 continue
  50 c      write (iout,*) "Sidechain"
  51       call flush(iout)
  52       call vec_and_deriv
  53       if (shield_mode.eq.1) then
  54        call set_shield_fac
  55       else if  (shield_mode.eq.2) then
  56        call set_shield_fac2
  57       endif
  58       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  59 c            write(iout,*) 'po eelec'
  60 c      call flush(iout)
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       if (wang.gt.0d0) then
  83        if (tor_mode.eq.0) then
  84          call ebend(ebe)
  85        else
  86 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  87 C energy function
  88          call ebend_kcc(ebe)
  89        endif
  90       else
  91         ebe=0.0d0
  92       endif
  93       ethetacnstr=0.0d0
  94       if (with_theta_constr) call etheta_constr(ethetacnstr)
  95 c      call ebend(ebe,ethetacnstr)
  96 cd    print *,'Bend energy finished.'
  97 C
  98 C Calculate the SC local energy.
  99 C
 100       call esc(escloc)
 101 C       print *,'SCLOC energy finished.'
 102 C
 103 C Calculate the virtual-bond torsional energy.
 104 C
 105       if (wtor.gt.0.0d0) then
 106          if (tor_mode.eq.0) then
 107            call etor(etors,fact(1))
 108          else
 109 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 110 C energy function
 111            call etor_kcc(etors,fact(1))
 112          endif
 113       else
 114         etors=0.0d0
 115       endif
 116       edihcnstr=0.0d0
 117       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 118 c      print *,"Processor",myrank," computed Utor"
 119 C
 120 C 6/23/01 Calculate double-torsional energy
 121 C
 122       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 123         call etor_d(etors_d,fact(2))
 124       else
 125         etors_d=0
 126       endif
 127 c      print *,"Processor",myrank," computed Utord"
 128 C
 129       call eback_sc_corr(esccor)
 130
 131       if (wliptran.gt.0) then
 132         call Eliptransfer(eliptran)
 133       endif
 134
 135 C
 136 C 12/1/95 Multi-body terms
 137 C
 138       n_corr=0
 139       n_corr1=0
 140       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 141      &    .or. wturn6.gt.0.0d0) then
 142 c         write(iout,*)"calling multibody_eello"
 143          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 144 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 145 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 146       else
 147          ecorr=0.0d0
 148          ecorr5=0.0d0
 149          ecorr6=0.0d0
 150          eturn6=0.0d0
 151       endif
 152       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 153 c         write (iout,*) "Calling multibody_hbond"
 154          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 155       endif
 156 c      write (iout,*) "NSAXS",nsaxs
 157       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 158         call e_saxs(Esaxs_constr)
 159 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 160       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 161         call e_saxsC(Esaxs_constr)
 162 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 163       else
 164         Esaxs_constr = 0.0d0
 165       endif
 166 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 167       if (constr_homology.ge.1) then
 168         call e_modeller(ehomology_constr)
 169       else
 170         ehomology_constr=0.0d0
 171       endif
 172
 173 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 174 #ifdef DFA
 175 C     BARTEK for dfa test!
 176       if (wdfa_dist.gt.0) call edfad(edfadis)
 177 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 178       if (wdfa_tor.gt.0) call edfat(edfator)
 179 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 180       if (wdfa_nei.gt.0) call edfan(edfanei)
 181 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 182       if (wdfa_beta.gt.0) call edfab(edfabet)
 183 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 184 #endif
 185
 186 #ifdef SPLITELE
 187       if (shield_mode.gt.0) then
 188       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 189      & +welec*fact(1)*ees
 190      & +fact(1)*wvdwpp*evdw1
 191      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 192      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 193      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 194      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 195      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 196      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 197      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 198      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 199      & +wdfa_beta*edfabet
 200       else
 201       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 202      & +wvdwpp*evdw1
 203      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 204      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 205      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 206      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 207      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 208      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 209      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 210      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 211      & +wdfa_beta*edfabet
 212       endif
 213 #else
 214       if (shield_mode.gt.0) then
 215       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 216      & +welec*fact(1)*(ees+evdw1)
 217      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 218      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 219      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 220      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 221      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 222      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 223      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 224      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 225      & +wdfa_beta*edfabet
 226       else
 227       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 228      & +welec*fact(1)*(ees+evdw1)
 229      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 230      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 231      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 232      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 233      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 234      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 235      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 236      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 237      & +wdfa_beta*edfabet
 238       endif
 239 #endif
 240       energia(0)=etot
 241       energia(1)=evdw
 242 #ifdef SCP14
 243       energia(2)=evdw2-evdw2_14
 244       energia(17)=evdw2_14
 245 #else
 246       energia(2)=evdw2
 247       energia(17)=0.0d0
 248 #endif
 249 #ifdef SPLITELE
 250       energia(3)=ees
 251       energia(16)=evdw1
 252 #else
 253       energia(3)=ees+evdw1
 254       energia(16)=0.0d0
 255 #endif
 256       energia(4)=ecorr
 257       energia(5)=ecorr5
 258       energia(6)=ecorr6
 259       energia(7)=eel_loc
 260       energia(8)=eello_turn3
 261       energia(9)=eello_turn4
 262       energia(10)=eturn6
 263       energia(11)=ebe
 264       energia(12)=escloc
 265       energia(13)=etors
 266       energia(14)=etors_d
 267       energia(15)=ehpb
 268       energia(18)=estr
 269       energia(19)=esccor
 270       energia(20)=edihcnstr
 271       energia(21)=evdw_t
 272       energia(22)=eliptran
 273       energia(24)=ethetacnstr
 274       energia(26)=esaxs_constr
 275       energia(27)=ehomology_constr
 276       energia(28)=edfadis
 277       energia(29)=edfator
 278       energia(30)=edfanei
 279       energia(31)=edfabet
 280 c detecting NaNQ
 281 #ifdef ISNAN
 282 #ifdef AIX
 283       if (isnan(etot).ne.0) energia(0)=1.0d+99
 284 #else
 285       if (isnan(etot)) energia(0)=1.0d+99
 286 #endif
 287 #else
 288       i=0
 289 #ifdef WINPGI
 290       idumm=proc_proc(etot,i)
 291 #else
 292       call proc_proc(etot,i)
 293 #endif
 294       if(i.eq.1)energia(0)=1.0d+99
 295 #endif
 296 #ifdef MPL
 297 c     endif
 298 #endif
 299 #ifdef DEBUG
 300       call enerprint(energia,fact)
 301 #endif
 302       if (calc_grad) then
 303 C
 304 C Sum up the components of the Cartesian gradient.
 305 C
 306 #ifdef SPLITELE
 307       do i=1,nct
 308         do j=1,3
 309       if (shield_mode.eq.0) then
 310           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 311      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 312      &                wbond*gradb(j,i)+
 313      &                wstrain*ghpbc(j,i)+
 314      &                wcorr*fact(3)*gradcorr(j,i)+
 315      &                wel_loc*fact(2)*gel_loc(j,i)+
 316      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 317      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 318      &                wcorr5*fact(4)*gradcorr5(j,i)+
 319      &                wcorr6*fact(5)*gradcorr6(j,i)+
 320      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 321      &                wsccor*fact(2)*gsccorc(j,i)
 322      &               +wliptran*gliptranc(j,i)+
 323      &                wdfa_dist*gdfad(j,i)+
 324      &                wdfa_tor*gdfat(j,i)+
 325      &                wdfa_nei*gdfan(j,i)+
 326      &                wdfa_beta*gdfab(j,i)
 327           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 328      &                  wbond*gradbx(j,i)+
 329      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 330      &                  wsccor*fact(2)*gsccorx(j,i)
 331      &                 +wliptran*gliptranx(j,i)
 332         else
 333           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 334      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 335      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 336      &                wbond*gradb(j,i)+
 337      &                wstrain*ghpbc(j,i)+
 338      &                wcorr*fact(3)*gradcorr(j,i)+
 339      &                wel_loc*fact(2)*gel_loc(j,i)+
 340      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 341      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 342      &                wcorr5*fact(4)*gradcorr5(j,i)+
 343      &                wcorr6*fact(5)*gradcorr6(j,i)+
 344      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 345      &                wsccor*fact(2)*gsccorc(j,i)
 346      &               +wliptran*gliptranc(j,i)
 347      &                 +welec*gshieldc(j,i)
 348      &                 +welec*gshieldc_loc(j,i)
 349      &                 +wcorr*gshieldc_ec(j,i)
 350      &                 +wcorr*gshieldc_loc_ec(j,i)
 351      &                 +wturn3*gshieldc_t3(j,i)
 352      &                 +wturn3*gshieldc_loc_t3(j,i)
 353      &                 +wturn4*gshieldc_t4(j,i)
 354      &                 +wturn4*gshieldc_loc_t4(j,i)
 355      &                 +wel_loc*gshieldc_ll(j,i)
 356      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 357      &                wdfa_dist*gdfad(j,i)+
 358      &                wdfa_tor*gdfat(j,i)+
 359      &                wdfa_nei*gdfan(j,i)+
 360      &                wdfa_beta*gdfab(j,i)
 361           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 362      &                 +fact(1)*wscp*gradx_scp(j,i)+
 363      &                  wbond*gradbx(j,i)+
 364      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 365      &                  wsccor*fact(2)*gsccorx(j,i)
 366      &                 +wliptran*gliptranx(j,i)
 367      &                 +welec*gshieldx(j,i)
 368      &                 +wcorr*gshieldx_ec(j,i)
 369      &                 +wturn3*gshieldx_t3(j,i)
 370      &                 +wturn4*gshieldx_t4(j,i)
 371      &                 +wel_loc*gshieldx_ll(j,i)
 372
 373
 374         endif
 375         enddo
 376 #else
 377       do i=1,nct
 378         do j=1,3
 379                 if (shield_mode.eq.0) then
 380           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 381      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 382      &                wbond*gradb(j,i)+
 383      &                wcorr*fact(3)*gradcorr(j,i)+
 384      &                wel_loc*fact(2)*gel_loc(j,i)+
 385      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 386      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 387      &                wcorr5*fact(4)*gradcorr5(j,i)+
 388      &                wcorr6*fact(5)*gradcorr6(j,i)+
 389      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 390      &                wsccor*fact(2)*gsccorc(j,i)
 391      &               +wliptran*gliptranc(j,i)+
 392      &                wdfa_dist*gdfad(j,i)+
 393      &                wdfa_tor*gdfat(j,i)+
 394      &                wdfa_nei*gdfan(j,i)+
 395      &                wdfa_beta*gdfab(j,i)
 396           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 397      &                  wbond*gradbx(j,i)+
 398      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 399      &                  wsccor*fact(1)*gsccorx(j,i)
 400      &                 +wliptran*gliptranx(j,i)
 401               else
 402           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 403      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 404      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 405      &                wbond*gradb(j,i)+
 406      &                wcorr*fact(3)*gradcorr(j,i)+
 407      &                wel_loc*fact(2)*gel_loc(j,i)+
 408      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 409      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 410      &                wcorr5*fact(4)*gradcorr5(j,i)+
 411      &                wcorr6*fact(5)*gradcorr6(j,i)+
 412      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 413      &                wsccor*fact(2)*gsccorc(j,i)
 414      &               +wliptran*gliptranc(j,i)
 415      &                 +welec*gshieldc(j,i)
 416      &                 +welec*gshieldc_loc(j,i)
 417      &                 +wcorr*gshieldc_ec(j,i)
 418      &                 +wcorr*gshieldc_loc_ec(j,i)
 419      &                 +wturn3*gshieldc_t3(j,i)
 420      &                 +wturn3*gshieldc_loc_t3(j,i)
 421      &                 +wturn4*gshieldc_t4(j,i)
 422      &                 +wturn4*gshieldc_loc_t4(j,i)
 423      &                 +wel_loc*gshieldc_ll(j,i)
 424      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 425      &                wdfa_dist*gdfad(j,i)+
 426      &                wdfa_tor*gdfat(j,i)+
 427      &                wdfa_nei*gdfan(j,i)+
 428      &                wdfa_beta*gdfab(j,i)
 429           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 430      &                  fact(1)*wscp*gradx_scp(j,i)+
 431      &                  wbond*gradbx(j,i)+
 432      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 433      &                  wsccor*fact(1)*gsccorx(j,i)
 434      &                 +wliptran*gliptranx(j,i)
 435      &                 +welec*gshieldx(j,i)
 436      &                 +wcorr*gshieldx_ec(j,i)
 437      &                 +wturn3*gshieldx_t3(j,i)
 438      &                 +wturn4*gshieldx_t4(j,i)
 439      &                 +wel_loc*gshieldx_ll(j,i)
 440          endif
 441         enddo
 442 #endif
 443       enddo
 444
 445
 446       do i=1,nres-3
 447         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 448      &   +wcorr5*fact(4)*g_corr5_loc(i)
 449      &   +wcorr6*fact(5)*g_corr6_loc(i)
 450      &   +wturn4*fact(3)*gel_loc_turn4(i)
 451      &   +wturn3*fact(2)*gel_loc_turn3(i)
 452      &   +wturn6*fact(5)*gel_loc_turn6(i)
 453      &   +wel_loc*fact(2)*gel_loc_loc(i)
 454 c     &   +wsccor*fact(1)*gsccor_loc(i)
 455 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 456       enddo
 457       endif
 458       if (dyn_ss) call dyn_set_nss
 459       return
 460       end
 461 C------------------------------------------------------------------------
 462       subroutine enerprint(energia,fact)
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465       include 'COMMON.IOUNITS'
 466       include 'COMMON.FFIELD'
 467       include 'COMMON.SBRIDGE'
 468       include 'COMMON.CONTROL'
 469       double precision energia(0:max_ene),fact(6)
 470       etot=energia(0)
 471       evdw=energia(1)+fact(6)*energia(21)
 472 #ifdef SCP14
 473       evdw2=energia(2)+energia(17)
 474 #else
 475       evdw2=energia(2)
 476 #endif
 477       ees=energia(3)
 478 #ifdef SPLITELE
 479       evdw1=energia(16)
 480 #endif
 481       ecorr=energia(4)
 482       ecorr5=energia(5)
 483       ecorr6=energia(6)
 484       eel_loc=energia(7)
 485       eello_turn3=energia(8)
 486       eello_turn4=energia(9)
 487       eello_turn6=energia(10)
 488       ebe=energia(11)
 489       escloc=energia(12)
 490       etors=energia(13)
 491       etors_d=energia(14)
 492       ehpb=energia(15)
 493       esccor=energia(19)
 494       edihcnstr=energia(20)
 495       estr=energia(18)
 496       ethetacnstr=energia(24)
 497       eliptran=energia(22)
 498       esaxs=energia(26)
 499       ehomology_constr=energia(27)
 500 C     Bartek
 501       edfadis = energia(28)
 502       edfator = energia(29)
 503       edfanei = energia(30)
 504       edfabet = energia(31)
 505 #ifdef SPLITELE
 506       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 507      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 508      &  etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3),
 509      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),eel_loc,
 510      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 511      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 512      &  esccor,wsccor*fact(1),edihcnstr,
 513      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 514      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 515      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 516      &  edfabet,wdfa_beta,
 517      &  etot
 518    10 format (/'Virtual-chain energies:'//
 519      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 520      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 521      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 522      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 523      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 524      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 525      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 526      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 527      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 528      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 529      & ' (SS bridges & dist. cnstr.)'/
 530      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 531      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 532      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 533      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 534      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 535      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 536      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 537      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 538      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 539      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 540      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 541      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 542      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 543      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 544      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 545      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 546      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 547      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 548      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 549      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 550      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 551      & 'ETOT=  ',1pE16.6,' (total)')
 552
 553 #else
 554       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 555      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 556      &  etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3),
 557      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 558      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 559      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 560      &  esccor,wsccor*fact(1),edihcnstr,
 561      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 562      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 563      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 564      &  edfabet,wdfa_beta,
 565      &  etot
 566    10 format (/'Virtual-chain energies:'//
 567      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 568      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 569      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 570      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 571      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 572      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 573      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 574      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 575      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 576      & ' (SS bridges & dist. restr.)'/
 577      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 578      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 579      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 580      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 581      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 582      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 583      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 584      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 585      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 586      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 587      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 588      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 589      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 590      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 591      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 592      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 593      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 594      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 595      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 596      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 597      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 598      & 'ETOT=  ',1pE16.6,' (total)')
 599 #endif
 600       return
 601       end
 602 C-----------------------------------------------------------------------
 603       subroutine elj(evdw,evdw_t)
 604 C
 605 C This subroutine calculates the interaction energy of nonbonded side chains
 606 C assuming the LJ potential of interaction.
 607 C
 608       implicit real*8 (a-h,o-z)
 609       include 'DIMENSIONS'
 610       include "DIMENSIONS.COMPAR"
 611       parameter (accur=1.0d-10)
 612       include 'COMMON.GEO'
 613       include 'COMMON.VAR'
 614       include 'COMMON.LOCAL'
 615       include 'COMMON.CHAIN'
 616       include 'COMMON.DERIV'
 617       include 'COMMON.INTERACT'
 618       include 'COMMON.TORSION'
 619       include 'COMMON.SBRIDGE'
 620       include 'COMMON.NAMES'
 621       include 'COMMON.IOUNITS'
 622       include 'COMMON.CONTACTS'
 623       dimension gg(3)
 624       integer icant
 625       external icant
 626 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 627 c ROZNICA z cluster
 628 c      do i=1,210
 629 c        do j=1,2
 630 c          eneps_temp(j,i)=0.0d0
 631 c        enddo
 632 c      enddo
 633 cROZNICA
 634
 635       evdw=0.0D0
 636       evdw_t=0.0d0
 637       do i=iatsc_s,iatsc_e
 638         itypi=iabs(itype(i))
 639         if (itypi.eq.ntyp1) cycle
 640         itypi1=iabs(itype(i+1))
 641         xi=c(1,nres+i)
 642         yi=c(2,nres+i)
 643         zi=c(3,nres+i)
 644 C Change 12/1/95
 645         num_conti=0
 646 C
 647 C Calculate SC interaction energy.
 648 C
 649         do iint=1,nint_gr(i)
 650 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 651 cd   &                  'iend=',iend(i,iint)
 652           do j=istart(i,iint),iend(i,iint)
 653             itypj=iabs(itype(j))
 654             if (itypj.eq.ntyp1) cycle
 655             xj=c(1,nres+j)-xi
 656             yj=c(2,nres+j)-yi
 657             zj=c(3,nres+j)-zi
 658 C Change 12/1/95 to calculate four-body interactions
 659             rij=xj*xj+yj*yj+zj*zj
 660             rrij=1.0D0/rij
 661 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 662             eps0ij=eps(itypi,itypj)
 663             fac=rrij**expon2
 664             e1=fac*fac*aa
 665             e2=fac*bb
 666             evdwij=e1+e2
 667             ij=icant(itypi,itypj)
 668 c ROZNICA z cluster
 669 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 670 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 671 c
 672
 673 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 674 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 675 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 676 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 677 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 678 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 679             if (bb.gt.0.0d0) then
 680               evdw=evdw+evdwij
 681             else
 682               evdw_t=evdw_t+evdwij
 683             endif
 684             if (calc_grad) then
 685 C
 686 C Calculate the components of the gradient in DC and X
 687 C
 688             fac=-rrij*(e1+evdwij)
 689             gg(1)=xj*fac
 690             gg(2)=yj*fac
 691             gg(3)=zj*fac
 692             do k=1,3
 693               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 694               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 695             enddo
 696             do k=i,j-1
 697               do l=1,3
 698                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 699               enddo
 700             enddo
 701             endif
 702 C
 703 C 12/1/95, revised on 5/20/97
 704 C
 705 C Calculate the contact function. The ith column of the array JCONT will
 706 C contain the numbers of atoms that make contacts with the atom I (of numbers
 707 C greater than I). The arrays FACONT and GACONT will contain the values of
 708 C the contact function and its derivative.
 709 C
 710 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 711 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 712 C Uncomment next line, if the correlation interactions are contact function only
 713             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 714               rij=dsqrt(rij)
 715               sigij=sigma(itypi,itypj)
 716               r0ij=rs0(itypi,itypj)
 717 C
 718 C Check whether the SC's are not too far to make a contact.
 719 C
 720               rcut=1.5d0*r0ij
 721               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 722 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 723 C
 724               if (fcont.gt.0.0D0) then
 725 C If the SC-SC distance if close to sigma, apply spline.
 726 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 727 cAdam &             fcont1,fprimcont1)
 728 cAdam           fcont1=1.0d0-fcont1
 729 cAdam           if (fcont1.gt.0.0d0) then
 730 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 731 cAdam             fcont=fcont*fcont1
 732 cAdam           endif
 733 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 734 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 735 cga             do k=1,3
 736 cga               gg(k)=gg(k)*eps0ij
 737 cga             enddo
 738 cga             eps0ij=-evdwij*eps0ij
 739 C Uncomment for AL's type of SC correlation interactions.
 740 cadam           eps0ij=-evdwij
 741                 num_conti=num_conti+1
 742                 jcont(num_conti,i)=j
 743                 facont(num_conti,i)=fcont*eps0ij
 744                 fprimcont=eps0ij*fprimcont/rij
 745                 fcont=expon*fcont
 746 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 747 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 748 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 749 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 750                 gacont(1,num_conti,i)=-fprimcont*xj
 751                 gacont(2,num_conti,i)=-fprimcont*yj
 752                 gacont(3,num_conti,i)=-fprimcont*zj
 753 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 754 cd              write (iout,'(2i3,3f10.5)')
 755 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 756               endif
 757             endif
 758           enddo      ! j
 759         enddo        ! iint
 760 C Change 12/1/95
 761         num_cont(i)=num_conti
 762       enddo          ! i
 763       if (calc_grad) then
 764       do i=1,nct
 765         do j=1,3
 766           gvdwc(j,i)=expon*gvdwc(j,i)
 767           gvdwx(j,i)=expon*gvdwx(j,i)
 768         enddo
 769       enddo
 770       endif
 771 C******************************************************************************
 772 C
 773 C                              N O T E !!!
 774 C
 775 C To save time, the factor of EXPON has been extracted from ALL components
 776 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 777 C use!
 778 C
 779 C******************************************************************************
 780       return
 781       end
 782 C-----------------------------------------------------------------------------
 783       subroutine eljk(evdw,evdw_t)
 784 C
 785 C This subroutine calculates the interaction energy of nonbonded side chains
 786 C assuming the LJK potential of interaction.
 787 C
 788       implicit real*8 (a-h,o-z)
 789       include 'DIMENSIONS'
 790       include "DIMENSIONS.COMPAR"
 791       include 'COMMON.GEO'
 792       include 'COMMON.VAR'
 793       include 'COMMON.LOCAL'
 794       include 'COMMON.CHAIN'
 795       include 'COMMON.DERIV'
 796       include 'COMMON.INTERACT'
 797       include 'COMMON.IOUNITS'
 798       include 'COMMON.NAMES'
 799       dimension gg(3)
 800       logical scheck
 801       integer icant
 802       external icant
 803 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 804 c      do i=1,210
 805 c        do j=1,2
 806 c          eneps_temp(j,i)=0.0d0
 807 c        enddo
 808 c      enddo
 809       evdw=0.0D0
 810       evdw_t=0.0d0
 811       do i=iatsc_s,iatsc_e
 812         itypi=iabs(itype(i))
 813         if (itypi.eq.ntyp1) cycle
 814         itypi1=iabs(itype(i+1))
 815         xi=c(1,nres+i)
 816         yi=c(2,nres+i)
 817         zi=c(3,nres+i)
 818 C
 819 C Calculate SC interaction energy.
 820 C
 821         do iint=1,nint_gr(i)
 822           do j=istart(i,iint),iend(i,iint)
 823             itypj=iabs(itype(j))
 824             if (itypj.eq.ntyp1) cycle
 825             xj=c(1,nres+j)-xi
 826             yj=c(2,nres+j)-yi
 827             zj=c(3,nres+j)-zi
 828             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 829             fac_augm=rrij**expon
 830             e_augm=augm(itypi,itypj)*fac_augm
 831             r_inv_ij=dsqrt(rrij)
 832             rij=1.0D0/r_inv_ij
 833             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 834             fac=r_shift_inv**expon
 835             e1=fac*fac*aa
 836             e2=fac*bb
 837             evdwij=e_augm+e1+e2
 838             ij=icant(itypi,itypj)
 839 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 840 c     &        /dabs(eps(itypi,itypj))
 841 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 842 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 843 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 844 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 845 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 846 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 847 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 848 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 849             if (bb.gt.0.0d0) then
 850               evdw=evdw+evdwij
 851             else
 852               evdw_t=evdw_t+evdwij
 853             endif
 854             if (calc_grad) then
 855 C
 856 C Calculate the components of the gradient in DC and X
 857 C
 858             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 859             gg(1)=xj*fac
 860             gg(2)=yj*fac
 861             gg(3)=zj*fac
 862             do k=1,3
 863               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 864               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 865             enddo
 866             do k=i,j-1
 867               do l=1,3
 868                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 869               enddo
 870             enddo
 871             endif
 872           enddo      ! j
 873         enddo        ! iint
 874       enddo          ! i
 875       if (calc_grad) then
 876       do i=1,nct
 877         do j=1,3
 878           gvdwc(j,i)=expon*gvdwc(j,i)
 879           gvdwx(j,i)=expon*gvdwx(j,i)
 880         enddo
 881       enddo
 882       endif
 883       return
 884       end
 885 C-----------------------------------------------------------------------------
 886       subroutine ebp(evdw,evdw_t)
 887 C
 888 C This subroutine calculates the interaction energy of nonbonded side chains
 889 C assuming the Berne-Pechukas potential of interaction.
 890 C
 891       implicit real*8 (a-h,o-z)
 892       include 'DIMENSIONS'
 893       include "DIMENSIONS.COMPAR"
 894       include 'COMMON.GEO'
 895       include 'COMMON.VAR'
 896       include 'COMMON.LOCAL'
 897       include 'COMMON.CHAIN'
 898       include 'COMMON.DERIV'
 899       include 'COMMON.NAMES'
 900       include 'COMMON.INTERACT'
 901       include 'COMMON.IOUNITS'
 902       include 'COMMON.CALC'
 903       common /srutu/ icall
 904 c     double precision rrsave(maxdim)
 905       logical lprn
 906       integer icant
 907       external icant
 908 c      do i=1,210
 909 c        do j=1,2
 910 c          eneps_temp(j,i)=0.0d0
 911 c        enddo
 912 c      enddo
 913       evdw=0.0D0
 914       evdw_t=0.0d0
 915 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 916 c     if (icall.eq.0) then
 917 c       lprn=.true.
 918 c     else
 919         lprn=.false.
 920 c     endif
 921       ind=0
 922       do i=iatsc_s,iatsc_e
 923         itypi=iabs(itype(i))
 924         if (itypi.eq.ntyp1) cycle
 925         itypi1=iabs(itype(i+1))
 926         xi=c(1,nres+i)
 927         yi=c(2,nres+i)
 928         zi=c(3,nres+i)
 929         dxi=dc_norm(1,nres+i)
 930         dyi=dc_norm(2,nres+i)
 931         dzi=dc_norm(3,nres+i)
 932         dsci_inv=vbld_inv(i+nres)
 933 C
 934 C Calculate SC interaction energy.
 935 C
 936         do iint=1,nint_gr(i)
 937           do j=istart(i,iint),iend(i,iint)
 938             ind=ind+1
 939             itypj=iabs(itype(j))
 940             if (itypj.eq.ntyp1) cycle
 941             dscj_inv=vbld_inv(j+nres)
 942             chi1=chi(itypi,itypj)
 943             chi2=chi(itypj,itypi)
 944             chi12=chi1*chi2
 945             chip1=chip(itypi)
 946             chip2=chip(itypj)
 947             chip12=chip1*chip2
 948             alf1=alp(itypi)
 949             alf2=alp(itypj)
 950             alf12=0.5D0*(alf1+alf2)
 951 C For diagnostics only!!!
 952 c           chi1=0.0D0
 953 c           chi2=0.0D0
 954 c           chi12=0.0D0
 955 c           chip1=0.0D0
 956 c           chip2=0.0D0
 957 c           chip12=0.0D0
 958 c           alf1=0.0D0
 959 c           alf2=0.0D0
 960 c           alf12=0.0D0
 961             xj=c(1,nres+j)-xi
 962             yj=c(2,nres+j)-yi
 963             zj=c(3,nres+j)-zi
 964             dxj=dc_norm(1,nres+j)
 965             dyj=dc_norm(2,nres+j)
 966             dzj=dc_norm(3,nres+j)
 967             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 968 cd          if (icall.eq.0) then
 969 cd            rrsave(ind)=rrij
 970 cd          else
 971 cd            rrij=rrsave(ind)
 972 cd          endif
 973             rij=dsqrt(rrij)
 974 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 975             call sc_angular
 976 C Calculate whole angle-dependent part of epsilon and contributions
 977 C to its derivatives
 978             fac=(rrij*sigsq)**expon2
 979             e1=fac*fac*aa
 980             e2=fac*bb
 981             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 982             eps2der=evdwij*eps3rt
 983             eps3der=evdwij*eps2rt
 984             evdwij=evdwij*eps2rt*eps3rt
 985             ij=icant(itypi,itypj)
 986             aux=eps1*eps2rt**2*eps3rt**2
 987 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 988 c     &        /dabs(eps(itypi,itypj))
 989 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 990             if (bb.gt.0.0d0) then
 991               evdw=evdw+evdwij
 992             else
 993               evdw_t=evdw_t+evdwij
 994             endif
 995             if (calc_grad) then
 996             if (lprn) then
 997             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 998             epsi=bb**2/aa
 999             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1000      &        restyp(itypi),i,restyp(itypj),j,
1001      &        epsi,sigm,chi1,chi2,chip1,chip2,
1002      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1003      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1004      &        evdwij
1005             endif
1006 C Calculate gradient components.
1007             e1=e1*eps1*eps2rt**2*eps3rt**2
1008             fac=-expon*(e1+evdwij)
1009             sigder=fac/sigsq
1010             fac=rrij*fac
1011 C Calculate radial part of the gradient
1012             gg(1)=xj*fac
1013             gg(2)=yj*fac
1014             gg(3)=zj*fac
1015 C Calculate the angular part of the gradient and sum add the contributions
1016 C to the appropriate components of the Cartesian gradient.
1017             call sc_grad
1018             endif
1019           enddo      ! j
1020         enddo        ! iint
1021       enddo          ! i
1022 c     stop
1023       return
1024       end
1025 C-----------------------------------------------------------------------------
1026       subroutine egb(evdw,evdw_t)
1027 C
1028 C This subroutine calculates the interaction energy of nonbonded side chains
1029 C assuming the Gay-Berne potential of interaction.
1030 C
1031       implicit real*8 (a-h,o-z)
1032       include 'DIMENSIONS'
1033       include "DIMENSIONS.COMPAR"
1034       include 'COMMON.GEO'
1035       include 'COMMON.VAR'
1036       include 'COMMON.LOCAL'
1037       include 'COMMON.CHAIN'
1038       include 'COMMON.DERIV'
1039       include 'COMMON.NAMES'
1040       include 'COMMON.INTERACT'
1041       include 'COMMON.IOUNITS'
1042       include 'COMMON.CALC'
1043       include 'COMMON.SBRIDGE'
1044       logical lprn
1045       common /srutu/icall
1046       integer icant,xshift,yshift,zshift
1047       external icant
1048 c      do i=1,210
1049 c        do j=1,2
1050 c          eneps_temp(j,i)=0.0d0
1051 c        enddo
1052 c      enddo
1053 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1054       evdw=0.0D0
1055       evdw_t=0.0d0
1056       lprn=.false.
1057 c      if (icall.gt.0) lprn=.true.
1058       ind=0
1059       do i=iatsc_s,iatsc_e
1060         itypi=iabs(itype(i))
1061         if (itypi.eq.ntyp1) cycle
1062         itypi1=iabs(itype(i+1))
1063         xi=c(1,nres+i)
1064         yi=c(2,nres+i)
1065         zi=c(3,nres+i)
1066 C returning the ith atom to box
1067           xi=mod(xi,boxxsize)
1068           if (xi.lt.0) xi=xi+boxxsize
1069           yi=mod(yi,boxysize)
1070           if (yi.lt.0) yi=yi+boxysize
1071           zi=mod(zi,boxzsize)
1072           if (zi.lt.0) zi=zi+boxzsize
1073        if ((zi.gt.bordlipbot)
1074      &.and.(zi.lt.bordliptop)) then
1075 C the energy transfer exist
1076         if (zi.lt.buflipbot) then
1077 C what fraction I am in
1078          fracinbuf=1.0d0-
1079      &        ((zi-bordlipbot)/lipbufthick)
1080 C lipbufthick is thickenes of lipid buffore
1081          sslipi=sscalelip(fracinbuf)
1082          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1083         elseif (zi.gt.bufliptop) then
1084          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1085          sslipi=sscalelip(fracinbuf)
1086          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1087         else
1088          sslipi=1.0d0
1089          ssgradlipi=0.0
1090         endif
1091        else
1092          sslipi=0.0d0
1093          ssgradlipi=0.0
1094        endif
1095
1096         dxi=dc_norm(1,nres+i)
1097         dyi=dc_norm(2,nres+i)
1098         dzi=dc_norm(3,nres+i)
1099         dsci_inv=vbld_inv(i+nres)
1100 C
1101 C Calculate SC interaction energy.
1102 C
1103         do iint=1,nint_gr(i)
1104           do j=istart(i,iint),iend(i,iint)
1105             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1106               call dyn_ssbond_ene(i,j,evdwij)
1107               evdw=evdw+evdwij
1108 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1109 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1110 C triple bond artifac removal
1111              do k=j+1,iend(i,iint)
1112 C search over all next residues
1113               if (dyn_ss_mask(k)) then
1114 C check if they are cysteins
1115 C              write(iout,*) 'k=',k
1116               call triple_ssbond_ene(i,j,k,evdwij)
1117 C call the energy function that removes the artifical triple disulfide
1118 C bond the soubroutine is located in ssMD.F
1119               evdw=evdw+evdwij
1120 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1121 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1122               endif!dyn_ss_mask(k)
1123              enddo! k
1124             ELSE
1125             ind=ind+1
1126             itypj=iabs(itype(j))
1127             if (itypj.eq.ntyp1) cycle
1128             dscj_inv=vbld_inv(j+nres)
1129             sig0ij=sigma(itypi,itypj)
1130             chi1=chi(itypi,itypj)
1131             chi2=chi(itypj,itypi)
1132             chi12=chi1*chi2
1133             chip1=chip(itypi)
1134             chip2=chip(itypj)
1135             chip12=chip1*chip2
1136             alf1=alp(itypi)
1137             alf2=alp(itypj)
1138             alf12=0.5D0*(alf1+alf2)
1139 C For diagnostics only!!!
1140 c           chi1=0.0D0
1141 c           chi2=0.0D0
1142 c           chi12=0.0D0
1143 c           chip1=0.0D0
1144 c           chip2=0.0D0
1145 c           chip12=0.0D0
1146 c           alf1=0.0D0
1147 c           alf2=0.0D0
1148 c           alf12=0.0D0
1149             xj=c(1,nres+j)
1150             yj=c(2,nres+j)
1151             zj=c(3,nres+j)
1152 C returning jth atom to box
1153           xj=mod(xj,boxxsize)
1154           if (xj.lt.0) xj=xj+boxxsize
1155           yj=mod(yj,boxysize)
1156           if (yj.lt.0) yj=yj+boxysize
1157           zj=mod(zj,boxzsize)
1158           if (zj.lt.0) zj=zj+boxzsize
1159        if ((zj.gt.bordlipbot)
1160      &.and.(zj.lt.bordliptop)) then
1161 C the energy transfer exist
1162         if (zj.lt.buflipbot) then
1163 C what fraction I am in
1164          fracinbuf=1.0d0-
1165      &        ((zj-bordlipbot)/lipbufthick)
1166 C lipbufthick is thickenes of lipid buffore
1167          sslipj=sscalelip(fracinbuf)
1168          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1169         elseif (zj.gt.bufliptop) then
1170          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1171          sslipj=sscalelip(fracinbuf)
1172          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1173         else
1174          sslipj=1.0d0
1175          ssgradlipj=0.0
1176         endif
1177        else
1178          sslipj=0.0d0
1179          ssgradlipj=0.0
1180        endif
1181       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1182      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1183       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1184      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1185 C       if (aa.ne.aa_aq(itypi,itypj)) then
1186
1187 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1188 C     & bb_aq(itypi,itypj)-bb,
1189 C     & sslipi,sslipj
1190 C         endif
1191
1192 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1193 C checking the distance
1194       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1195       xj_safe=xj
1196       yj_safe=yj
1197       zj_safe=zj
1198       subchap=0
1199 C finding the closest
1200       do xshift=-1,1
1201       do yshift=-1,1
1202       do zshift=-1,1
1203           xj=xj_safe+xshift*boxxsize
1204           yj=yj_safe+yshift*boxysize
1205           zj=zj_safe+zshift*boxzsize
1206           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1207           if(dist_temp.lt.dist_init) then
1208             dist_init=dist_temp
1209             xj_temp=xj
1210             yj_temp=yj
1211             zj_temp=zj
1212             subchap=1
1213           endif
1214        enddo
1215        enddo
1216        enddo
1217        if (subchap.eq.1) then
1218           xj=xj_temp-xi
1219           yj=yj_temp-yi
1220           zj=zj_temp-zi
1221        else
1222           xj=xj_safe-xi
1223           yj=yj_safe-yi
1224           zj=zj_safe-zi
1225        endif
1226
1227             dxj=dc_norm(1,nres+j)
1228             dyj=dc_norm(2,nres+j)
1229             dzj=dc_norm(3,nres+j)
1230 c            write (iout,*) i,j,xj,yj,zj
1231             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1232             rij=dsqrt(rrij)
1233             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1234             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1235             if (sss.le.0.0) cycle
1236 C Calculate angle-dependent terms of energy and contributions to their
1237 C derivatives.
1238
1239             call sc_angular
1240             sigsq=1.0D0/sigsq
1241             sig=sig0ij*dsqrt(sigsq)
1242             rij_shift=1.0D0/rij-sig+sig0ij
1243 C I hate to put IF's in the loops, but here don't have another choice!!!!
1244             if (rij_shift.le.0.0D0) then
1245               evdw=1.0D20
1246               return
1247             endif
1248             sigder=-sig*sigsq
1249 c---------------------------------------------------------------
1250             rij_shift=1.0D0/rij_shift
1251             fac=rij_shift**expon
1252             e1=fac*fac*aa
1253             e2=fac*bb
1254             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1255             eps2der=evdwij*eps3rt
1256             eps3der=evdwij*eps2rt
1257             evdwij=evdwij*eps2rt*eps3rt
1258             if (bb.gt.0) then
1259               evdw=evdw+evdwij*sss
1260             else
1261               evdw_t=evdw_t+evdwij*sss
1262             endif
1263             ij=icant(itypi,itypj)
1264             aux=eps1*eps2rt**2*eps3rt**2
1265 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1266 c     &        /dabs(eps(itypi,itypj))
1267 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1268 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1269 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1270 c     &         aux*e2/eps(itypi,itypj)
1271 c            if (lprn) then
1272             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1273             epsi=bb**2/aa
1274 C#define DEBUG
1275 #ifdef DEBUG
1276             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1277      &        restyp(itypi),i,restyp(itypj),j,
1278      &        epsi,sigm,chi1,chi2,chip1,chip2,
1279      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1280      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1281      &        evdwij
1282              write (iout,*) "partial sum", evdw, evdw_t
1283 #endif
1284 C#undef DEBUG
1285 c            endif
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(1)=xj*fac
1295             gg(2)=yj*fac
1296             gg(3)=zj*fac
1297 C Calculate angular part of the gradient.
1298             call sc_grad
1299             endif
1300 C            write(iout,*)  "partial sum", evdw, evdw_t
1301             ENDIF    ! dyn_ss
1302           enddo      ! j
1303         enddo        ! iint
1304       enddo          ! i
1305       return
1306       end
1307 C-----------------------------------------------------------------------------
1308       subroutine egbv(evdw,evdw_t)
1309 C
1310 C This subroutine calculates the interaction energy of nonbonded side chains
1311 C assuming the Gay-Berne-Vorobjev potential of interaction.
1312 C
1313       implicit real*8 (a-h,o-z)
1314       include 'DIMENSIONS'
1315       include "DIMENSIONS.COMPAR"
1316       include 'COMMON.GEO'
1317       include 'COMMON.VAR'
1318       include 'COMMON.LOCAL'
1319       include 'COMMON.CHAIN'
1320       include 'COMMON.DERIV'
1321       include 'COMMON.NAMES'
1322       include 'COMMON.INTERACT'
1323       include 'COMMON.IOUNITS'
1324       include 'COMMON.CALC'
1325       common /srutu/ icall
1326       logical lprn
1327       integer icant
1328       external icant
1329 c      do i=1,210
1330 c        do j=1,2
1331 c          eneps_temp(j,i)=0.0d0
1332 c        enddo
1333 c      enddo
1334       evdw=0.0D0
1335       evdw_t=0.0d0
1336 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1337       evdw=0.0D0
1338       lprn=.false.
1339 c      if (icall.gt.0) lprn=.true.
1340       ind=0
1341       do i=iatsc_s,iatsc_e
1342         itypi=iabs(itype(i))
1343         if (itypi.eq.ntyp1) cycle
1344         itypi1=iabs(itype(i+1))
1345         xi=c(1,nres+i)
1346         yi=c(2,nres+i)
1347         zi=c(3,nres+i)
1348         dxi=dc_norm(1,nres+i)
1349         dyi=dc_norm(2,nres+i)
1350         dzi=dc_norm(3,nres+i)
1351         dsci_inv=vbld_inv(i+nres)
1352 C
1353 C Calculate SC interaction energy.
1354 C
1355         do iint=1,nint_gr(i)
1356           do j=istart(i,iint),iend(i,iint)
1357             ind=ind+1
1358             itypj=iabs(itype(j))
1359             if (itypj.eq.ntyp1) cycle
1360             dscj_inv=vbld_inv(j+nres)
1361             sig0ij=sigma(itypi,itypj)
1362             r0ij=r0(itypi,itypj)
1363             chi1=chi(itypi,itypj)
1364             chi2=chi(itypj,itypi)
1365             chi12=chi1*chi2
1366             chip1=chip(itypi)
1367             chip2=chip(itypj)
1368             chip12=chip1*chip2
1369             alf1=alp(itypi)
1370             alf2=alp(itypj)
1371             alf12=0.5D0*(alf1+alf2)
1372 C For diagnostics only!!!
1373 c           chi1=0.0D0
1374 c           chi2=0.0D0
1375 c           chi12=0.0D0
1376 c           chip1=0.0D0
1377 c           chip2=0.0D0
1378 c           chip12=0.0D0
1379 c           alf1=0.0D0
1380 c           alf2=0.0D0
1381 c           alf12=0.0D0
1382             xj=c(1,nres+j)-xi
1383             yj=c(2,nres+j)-yi
1384             zj=c(3,nres+j)-zi
1385             dxj=dc_norm(1,nres+j)
1386             dyj=dc_norm(2,nres+j)
1387             dzj=dc_norm(3,nres+j)
1388             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1389             rij=dsqrt(rrij)
1390 C Calculate angle-dependent terms of energy and contributions to their
1391 C derivatives.
1392             call sc_angular
1393             sigsq=1.0D0/sigsq
1394             sig=sig0ij*dsqrt(sigsq)
1395             rij_shift=1.0D0/rij-sig+r0ij
1396 C I hate to put IF's in the loops, but here don't have another choice!!!!
1397             if (rij_shift.le.0.0D0) then
1398               evdw=1.0D20
1399               return
1400             endif
1401             sigder=-sig*sigsq
1402 c---------------------------------------------------------------
1403             rij_shift=1.0D0/rij_shift
1404             fac=rij_shift**expon
1405             e1=fac*fac*aa
1406             e2=fac*bb
1407             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1408             eps2der=evdwij*eps3rt
1409             eps3der=evdwij*eps2rt
1410             fac_augm=rrij**expon
1411             e_augm=augm(itypi,itypj)*fac_augm
1412             evdwij=evdwij*eps2rt*eps3rt
1413             if (bb.gt.0.0d0) then
1414               evdw=evdw+evdwij+e_augm
1415             else
1416               evdw_t=evdw_t+evdwij+e_augm
1417             endif
1418             ij=icant(itypi,itypj)
1419             aux=eps1*eps2rt**2*eps3rt**2
1420 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1421 c     &        /dabs(eps(itypi,itypj))
1422 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1423 c            eneps_temp(ij)=eneps_temp(ij)
1424 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1425 c            if (lprn) then
1426 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1427 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1428 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1429 c     &        restyp(itypi),i,restyp(itypj),j,
1430 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1431 c     &        chi1,chi2,chip1,chip2,
1432 c     &        eps1,eps2rt**2,eps3rt**2,
1433 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1434 c     &        evdwij+e_augm
1435 c            endif
1436             if (calc_grad) then
1437 C Calculate gradient components.
1438             e1=e1*eps1*eps2rt**2*eps3rt**2
1439             fac=-expon*(e1+evdwij)*rij_shift
1440             sigder=fac*sigder
1441             fac=rij*fac-2*expon*rrij*e_augm
1442 C Calculate the radial part of the gradient
1443             gg(1)=xj*fac
1444             gg(2)=yj*fac
1445             gg(3)=zj*fac
1446 C Calculate angular part of the gradient.
1447             call sc_grad
1448             endif
1449           enddo      ! j
1450         enddo        ! iint
1451       enddo          ! i
1452       return
1453       end
1454 C-----------------------------------------------------------------------------
1455       subroutine sc_angular
1456 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1457 C om12. Called by ebp, egb, and egbv.
1458       implicit none
1459       include 'COMMON.CALC'
1460       erij(1)=xj*rij
1461       erij(2)=yj*rij
1462       erij(3)=zj*rij
1463       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1464       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1465       om12=dxi*dxj+dyi*dyj+dzi*dzj
1466       chiom12=chi12*om12
1467 C Calculate eps1(om12) and its derivative in om12
1468       faceps1=1.0D0-om12*chiom12
1469       faceps1_inv=1.0D0/faceps1
1470       eps1=dsqrt(faceps1_inv)
1471 C Following variable is eps1*deps1/dom12
1472       eps1_om12=faceps1_inv*chiom12
1473 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1474 C and om12.
1475       om1om2=om1*om2
1476       chiom1=chi1*om1
1477       chiom2=chi2*om2
1478       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1479       sigsq=1.0D0-facsig*faceps1_inv
1480       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1481       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1482       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1483 C Calculate eps2 and its derivatives in om1, om2, and om12.
1484       chipom1=chip1*om1
1485       chipom2=chip2*om2
1486       chipom12=chip12*om12
1487       facp=1.0D0-om12*chipom12
1488       facp_inv=1.0D0/facp
1489       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1490 C Following variable is the square root of eps2
1491       eps2rt=1.0D0-facp1*facp_inv
1492 C Following three variables are the derivatives of the square root of eps
1493 C in om1, om2, and om12.
1494       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1495       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1496       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1497 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1498       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1499 C Calculate whole angle-dependent part of epsilon and contributions
1500 C to its derivatives
1501       return
1502       end
1503 C----------------------------------------------------------------------------
1504       subroutine sc_grad
1505       implicit real*8 (a-h,o-z)
1506       include 'DIMENSIONS'
1507       include 'COMMON.CHAIN'
1508       include 'COMMON.DERIV'
1509       include 'COMMON.CALC'
1510       double precision dcosom1(3),dcosom2(3)
1511       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1512       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1513       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1514      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1515       do k=1,3
1516         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1517         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1518       enddo
1519       do k=1,3
1520         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1521       enddo
1522       do k=1,3
1523         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1524      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1525      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1526         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1527      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1528      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1529       enddo
1530 C
1531 C Calculate the components of the gradient in DC and X
1532 C
1533       do k=i,j-1
1534         do l=1,3
1535           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1536         enddo
1537       enddo
1538       return
1539       end
1540 c------------------------------------------------------------------------------
1541       subroutine vec_and_deriv
1542       implicit real*8 (a-h,o-z)
1543       include 'DIMENSIONS'
1544       include 'COMMON.IOUNITS'
1545       include 'COMMON.GEO'
1546       include 'COMMON.VAR'
1547       include 'COMMON.LOCAL'
1548       include 'COMMON.CHAIN'
1549       include 'COMMON.VECTORS'
1550       include 'COMMON.DERIV'
1551       include 'COMMON.INTERACT'
1552       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1553 C Compute the local reference systems. For reference system (i), the
1554 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1555 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1556       do i=1,nres-1
1557 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1558           if (i.eq.nres-1) then
1559 C Case of the last full residue
1560 C Compute the Z-axis
1561             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1562             costh=dcos(pi-theta(nres))
1563             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1564 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1565 c     &         " uz",uz(:,i)
1566             do k=1,3
1567               uz(k,i)=fac*uz(k,i)
1568             enddo
1569             if (calc_grad) then
1570 C Compute the derivatives of uz
1571             uzder(1,1,1)= 0.0d0
1572             uzder(2,1,1)=-dc_norm(3,i-1)
1573             uzder(3,1,1)= dc_norm(2,i-1)
1574             uzder(1,2,1)= dc_norm(3,i-1)
1575             uzder(2,2,1)= 0.0d0
1576             uzder(3,2,1)=-dc_norm(1,i-1)
1577             uzder(1,3,1)=-dc_norm(2,i-1)
1578             uzder(2,3,1)= dc_norm(1,i-1)
1579             uzder(3,3,1)= 0.0d0
1580             uzder(1,1,2)= 0.0d0
1581             uzder(2,1,2)= dc_norm(3,i)
1582             uzder(3,1,2)=-dc_norm(2,i)
1583             uzder(1,2,2)=-dc_norm(3,i)
1584             uzder(2,2,2)= 0.0d0
1585             uzder(3,2,2)= dc_norm(1,i)
1586             uzder(1,3,2)= dc_norm(2,i)
1587             uzder(2,3,2)=-dc_norm(1,i)
1588             uzder(3,3,2)= 0.0d0
1589             endif ! calc_grad
1590 C Compute the Y-axis
1591             facy=fac
1592             do k=1,3
1593               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1594             enddo
1595             if (calc_grad) then
1596 C Compute the derivatives of uy
1597             do j=1,3
1598               do k=1,3
1599                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1600      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1601                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1602               enddo
1603               uyder(j,j,1)=uyder(j,j,1)-costh
1604               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1605             enddo
1606             do j=1,2
1607               do k=1,3
1608                 do l=1,3
1609                   uygrad(l,k,j,i)=uyder(l,k,j)
1610                   uzgrad(l,k,j,i)=uzder(l,k,j)
1611                 enddo
1612               enddo
1613             enddo
1614             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1615             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1616             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1617             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1618             endif
1619           else
1620 C Other residues
1621 C Compute the Z-axis
1622             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1623             costh=dcos(pi-theta(i+2))
1624             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1625             do k=1,3
1626               uz(k,i)=fac*uz(k,i)
1627             enddo
1628             if (calc_grad) then
1629 C Compute the derivatives of uz
1630             uzder(1,1,1)= 0.0d0
1631             uzder(2,1,1)=-dc_norm(3,i+1)
1632             uzder(3,1,1)= dc_norm(2,i+1)
1633             uzder(1,2,1)= dc_norm(3,i+1)
1634             uzder(2,2,1)= 0.0d0
1635             uzder(3,2,1)=-dc_norm(1,i+1)
1636             uzder(1,3,1)=-dc_norm(2,i+1)
1637             uzder(2,3,1)= dc_norm(1,i+1)
1638             uzder(3,3,1)= 0.0d0
1639             uzder(1,1,2)= 0.0d0
1640             uzder(2,1,2)= dc_norm(3,i)
1641             uzder(3,1,2)=-dc_norm(2,i)
1642             uzder(1,2,2)=-dc_norm(3,i)
1643             uzder(2,2,2)= 0.0d0
1644             uzder(3,2,2)= dc_norm(1,i)
1645             uzder(1,3,2)= dc_norm(2,i)
1646             uzder(2,3,2)=-dc_norm(1,i)
1647             uzder(3,3,2)= 0.0d0
1648             endif
1649 C Compute the Y-axis
1650             facy=fac
1651             do k=1,3
1652               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1653             enddo
1654             if (calc_grad) then
1655 C Compute the derivatives of uy
1656             do j=1,3
1657               do k=1,3
1658                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1659      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1660                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1661               enddo
1662               uyder(j,j,1)=uyder(j,j,1)-costh
1663               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1664             enddo
1665             do j=1,2
1666               do k=1,3
1667                 do l=1,3
1668                   uygrad(l,k,j,i)=uyder(l,k,j)
1669                   uzgrad(l,k,j,i)=uzder(l,k,j)
1670                 enddo
1671               enddo
1672             enddo
1673             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1674             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1675             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1676             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1677           endif
1678           endif
1679       enddo
1680       if (calc_grad) then
1681       do i=1,nres-1
1682         vbld_inv_temp(1)=vbld_inv(i+1)
1683         if (i.lt.nres-1) then
1684           vbld_inv_temp(2)=vbld_inv(i+2)
1685         else
1686           vbld_inv_temp(2)=vbld_inv(i)
1687         endif
1688         do j=1,2
1689           do k=1,3
1690             do l=1,3
1691               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1692               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1693             enddo
1694           enddo
1695         enddo
1696       enddo
1697       endif
1698       return
1699       end
1700 C--------------------------------------------------------------------------
1701       subroutine set_matrices
1702       implicit real*8 (a-h,o-z)
1703       include 'DIMENSIONS'
1704 #ifdef MPI
1705       include "mpif.h"
1706       integer IERR
1707       integer status(MPI_STATUS_SIZE)
1708 #endif
1709       include 'COMMON.IOUNITS'
1710       include 'COMMON.GEO'
1711       include 'COMMON.VAR'
1712       include 'COMMON.LOCAL'
1713       include 'COMMON.CHAIN'
1714       include 'COMMON.DERIV'
1715       include 'COMMON.INTERACT'
1716       include 'COMMON.CONTACTS'
1717       include 'COMMON.TORSION'
1718       include 'COMMON.VECTORS'
1719       include 'COMMON.FFIELD'
1720       double precision auxvec(2),auxmat(2,2)
1721 C
1722 C Compute the virtual-bond-torsional-angle dependent quantities needed
1723 C to calculate the el-loc multibody terms of various order.
1724 C
1725 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1726       do i=3,nres+1
1727         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1728           iti = itype2loc(itype(i-2))
1729         else
1730           iti=nloctyp
1731         endif
1732 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1733         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1734           iti1 = itype2loc(itype(i-1))
1735         else
1736           iti1=nloctyp
1737         endif
1738 #ifdef NEWCORR
1739         cost1=dcos(theta(i-1))
1740         sint1=dsin(theta(i-1))
1741         sint1sq=sint1*sint1
1742         sint1cub=sint1sq*sint1
1743         sint1cost1=2*sint1*cost1
1744 #ifdef DEBUG
1745         write (iout,*) "bnew1",i,iti
1746         write (iout,*) (bnew1(k,1,iti),k=1,3)
1747         write (iout,*) (bnew1(k,2,iti),k=1,3)
1748         write (iout,*) "bnew2",i,iti
1749         write (iout,*) (bnew2(k,1,iti),k=1,3)
1750         write (iout,*) (bnew2(k,2,iti),k=1,3)
1751 #endif
1752         do k=1,2
1753           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1754           b1(k,i-2)=sint1*b1k
1755           gtb1(k,i-2)=cost1*b1k-sint1sq*
1756      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1757           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1758           b2(k,i-2)=sint1*b2k
1759           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1760      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1761         enddo
1762         do k=1,2
1763           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1764           cc(1,k,i-2)=sint1sq*aux
1765           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1766      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1767           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1768           dd(1,k,i-2)=sint1sq*aux
1769           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1770      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1771         enddo
1772         cc(2,1,i-2)=cc(1,2,i-2)
1773         cc(2,2,i-2)=-cc(1,1,i-2)
1774         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1775         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1776         dd(2,1,i-2)=dd(1,2,i-2)
1777         dd(2,2,i-2)=-dd(1,1,i-2)
1778         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1779         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1780         do k=1,2
1781           do l=1,2
1782             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1783             EE(l,k,i-2)=sint1sq*aux
1784             if (calc_grad)
1785      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1786           enddo
1787         enddo
1788         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1789         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1790         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1791         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1792         if (calc_grad) then
1793         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1794         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1795         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1796         endif
1797 c        b1tilde(1,i-2)=b1(1,i-2)
1798 c        b1tilde(2,i-2)=-b1(2,i-2)
1799 c        b2tilde(1,i-2)=b2(1,i-2)
1800 c        b2tilde(2,i-2)=-b2(2,i-2)
1801 #ifdef DEBUG
1802         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1803         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1804         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1805         write (iout,*) 'theta=', theta(i-1)
1806 #endif
1807 #else
1808 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1809 c          iti = itype2loc(itype(i-2))
1810 c        else
1811 c          iti=nloctyp
1812 c        endif
1813 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1814 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1815 c          iti1 = itype2loc(itype(i-1))
1816 c        else
1817 c          iti1=nloctyp
1818 c        endif
1819         b1(1,i-2)=b(3,iti)
1820         b1(2,i-2)=b(5,iti)
1821         b2(1,i-2)=b(2,iti)
1822         b2(2,i-2)=b(4,iti)
1823         do k=1,2
1824           do l=1,2
1825            CC(k,l,i-2)=ccold(k,l,iti)
1826            DD(k,l,i-2)=ddold(k,l,iti)
1827            EE(k,l,i-2)=eeold(k,l,iti)
1828           enddo
1829         enddo
1830 #endif
1831         b1tilde(1,i-2)= b1(1,i-2)
1832         b1tilde(2,i-2)=-b1(2,i-2)
1833         b2tilde(1,i-2)= b2(1,i-2)
1834         b2tilde(2,i-2)=-b2(2,i-2)
1835 c
1836         Ctilde(1,1,i-2)= CC(1,1,i-2)
1837         Ctilde(1,2,i-2)= CC(1,2,i-2)
1838         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1839         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1840 c
1841         Dtilde(1,1,i-2)= DD(1,1,i-2)
1842         Dtilde(1,2,i-2)= DD(1,2,i-2)
1843         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1844         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1845 c        write(iout,*) "i",i," iti",iti
1846 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1847 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1848       enddo
1849       do i=3,nres+1
1850         if (i .lt. nres+1) then
1851           sin1=dsin(phi(i))
1852           cos1=dcos(phi(i))
1853           sintab(i-2)=sin1
1854           costab(i-2)=cos1
1855           obrot(1,i-2)=cos1
1856           obrot(2,i-2)=sin1
1857           sin2=dsin(2*phi(i))
1858           cos2=dcos(2*phi(i))
1859           sintab2(i-2)=sin2
1860           costab2(i-2)=cos2
1861           obrot2(1,i-2)=cos2
1862           obrot2(2,i-2)=sin2
1863           Ug(1,1,i-2)=-cos1
1864           Ug(1,2,i-2)=-sin1
1865           Ug(2,1,i-2)=-sin1
1866           Ug(2,2,i-2)= cos1
1867           Ug2(1,1,i-2)=-cos2
1868           Ug2(1,2,i-2)=-sin2
1869           Ug2(2,1,i-2)=-sin2
1870           Ug2(2,2,i-2)= cos2
1871         else
1872           costab(i-2)=1.0d0
1873           sintab(i-2)=0.0d0
1874           obrot(1,i-2)=1.0d0
1875           obrot(2,i-2)=0.0d0
1876           obrot2(1,i-2)=0.0d0
1877           obrot2(2,i-2)=0.0d0
1878           Ug(1,1,i-2)=1.0d0
1879           Ug(1,2,i-2)=0.0d0
1880           Ug(2,1,i-2)=0.0d0
1881           Ug(2,2,i-2)=1.0d0
1882           Ug2(1,1,i-2)=0.0d0
1883           Ug2(1,2,i-2)=0.0d0
1884           Ug2(2,1,i-2)=0.0d0
1885           Ug2(2,2,i-2)=0.0d0
1886         endif
1887         if (i .gt. 3 .and. i .lt. nres+1) then
1888           obrot_der(1,i-2)=-sin1
1889           obrot_der(2,i-2)= cos1
1890           Ugder(1,1,i-2)= sin1
1891           Ugder(1,2,i-2)=-cos1
1892           Ugder(2,1,i-2)=-cos1
1893           Ugder(2,2,i-2)=-sin1
1894           dwacos2=cos2+cos2
1895           dwasin2=sin2+sin2
1896           obrot2_der(1,i-2)=-dwasin2
1897           obrot2_der(2,i-2)= dwacos2
1898           Ug2der(1,1,i-2)= dwasin2
1899           Ug2der(1,2,i-2)=-dwacos2
1900           Ug2der(2,1,i-2)=-dwacos2
1901           Ug2der(2,2,i-2)=-dwasin2
1902         else
1903           obrot_der(1,i-2)=0.0d0
1904           obrot_der(2,i-2)=0.0d0
1905           Ugder(1,1,i-2)=0.0d0
1906           Ugder(1,2,i-2)=0.0d0
1907           Ugder(2,1,i-2)=0.0d0
1908           Ugder(2,2,i-2)=0.0d0
1909           obrot2_der(1,i-2)=0.0d0
1910           obrot2_der(2,i-2)=0.0d0
1911           Ug2der(1,1,i-2)=0.0d0
1912           Ug2der(1,2,i-2)=0.0d0
1913           Ug2der(2,1,i-2)=0.0d0
1914           Ug2der(2,2,i-2)=0.0d0
1915         endif
1916 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1917         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1918           iti = itype2loc(itype(i-2))
1919         else
1920           iti=nloctyp
1921         endif
1922 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1923         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1924           iti1 = itype2loc(itype(i-1))
1925         else
1926           iti1=nloctyp
1927         endif
1928 cd        write (iout,*) '*******i',i,' iti1',iti
1929 cd        write (iout,*) 'b1',b1(:,iti)
1930 cd        write (iout,*) 'b2',b2(:,iti)
1931 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1932 c        if (i .gt. iatel_s+2) then
1933         if (i .gt. nnt+2) then
1934           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1935 #ifdef NEWCORR
1936           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1937 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1938 #endif
1939 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1940 c     &    EE(1,2,iti),EE(2,2,i)
1941           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1942           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1943 c          write(iout,*) "Macierz EUG",
1944 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1945 c     &    eug(2,2,i-2)
1946           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1947      &    then
1948           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1949           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1950           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1951           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1952           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1953           endif
1954         else
1955           do k=1,2
1956             Ub2(k,i-2)=0.0d0
1957             Ctobr(k,i-2)=0.0d0
1958             Dtobr2(k,i-2)=0.0d0
1959             do l=1,2
1960               EUg(l,k,i-2)=0.0d0
1961               CUg(l,k,i-2)=0.0d0
1962               DUg(l,k,i-2)=0.0d0
1963               DtUg2(l,k,i-2)=0.0d0
1964             enddo
1965           enddo
1966         endif
1967         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1968         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1969         do k=1,2
1970           muder(k,i-2)=Ub2der(k,i-2)
1971         enddo
1972 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1973         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1974           if (itype(i-1).le.ntyp) then
1975             iti1 = itype2loc(itype(i-1))
1976           else
1977             iti1=nloctyp
1978           endif
1979         else
1980           iti1=nloctyp
1981         endif
1982         do k=1,2
1983           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
1984         enddo
1985 #ifdef MUOUT
1986         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
1987      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
1988      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
1989      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
1990      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
1991      &      ((ee(l,k,i-2),l=1,2),k=1,2)
1992 #endif
1993 cd        write (iout,*) 'mu1',mu1(:,i-2)
1994 cd        write (iout,*) 'mu2',mu2(:,i-2)
1995         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
1996      &  then
1997         if (calc_grad) then
1998         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1999         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2000         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2001         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2002         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2003         endif
2004 C Vectors and matrices dependent on a single virtual-bond dihedral.
2005         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2006         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2007         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2008         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2009         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2010         if (calc_grad) then
2011         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2012         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2013         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2014         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2015         endif
2016         endif
2017       enddo
2018 C Matrices dependent on two consecutive virtual-bond dihedrals.
2019 C The order of matrices is from left to right.
2020       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2021      &then
2022       do i=2,nres-1
2023         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2024         if (calc_grad) then
2025         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2026         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2027         endif
2028         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2029         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2030         if (calc_grad) then
2031         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2032         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2033         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2034         endif
2035       enddo
2036       endif
2037       return
2038       end
2039 C--------------------------------------------------------------------------
2040       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2041 C
2042 C This subroutine calculates the average interaction energy and its gradient
2043 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2044 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2045 C The potential depends both on the distance of peptide-group centers and on
2046 C the orientation of the CA-CA virtual bonds.
2047 C
2048       implicit real*8 (a-h,o-z)
2049 #ifdef MPI
2050       include 'mpif.h'
2051 #endif
2052       include 'DIMENSIONS'
2053       include 'COMMON.CONTROL'
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.GEO'
2056       include 'COMMON.VAR'
2057       include 'COMMON.LOCAL'
2058       include 'COMMON.CHAIN'
2059       include 'COMMON.DERIV'
2060       include 'COMMON.INTERACT'
2061       include 'COMMON.CONTACTS'
2062       include 'COMMON.TORSION'
2063       include 'COMMON.VECTORS'
2064       include 'COMMON.FFIELD'
2065       include 'COMMON.TIME1'
2066       include 'COMMON.SPLITELE'
2067       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2068      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2069       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2070      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2071       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2072      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2073      &    num_conti,j1,j2
2074 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2075 #ifdef MOMENT
2076       double precision scal_el /1.0d0/
2077 #else
2078       double precision scal_el /0.5d0/
2079 #endif
2080 C 12/13/98
2081 C 13-go grudnia roku pamietnego...
2082       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2083      &                   0.0d0,1.0d0,0.0d0,
2084      &                   0.0d0,0.0d0,1.0d0/
2085 cd      write(iout,*) 'In EELEC'
2086 cd      do i=1,nloctyp
2087 cd        write(iout,*) 'Type',i
2088 cd        write(iout,*) 'B1',B1(:,i)
2089 cd        write(iout,*) 'B2',B2(:,i)
2090 cd        write(iout,*) 'CC',CC(:,:,i)
2091 cd        write(iout,*) 'DD',DD(:,:,i)
2092 cd        write(iout,*) 'EE',EE(:,:,i)
2093 cd      enddo
2094 cd      call check_vecgrad
2095 cd      stop
2096       if (icheckgrad.eq.1) then
2097         do i=1,nres-1
2098           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2099           do k=1,3
2100             dc_norm(k,i)=dc(k,i)*fac
2101           enddo
2102 c          write (iout,*) 'i',i,' fac',fac
2103         enddo
2104       endif
2105       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2106      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2107      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2108 c        call vec_and_deriv
2109 #ifdef TIMING
2110         time01=MPI_Wtime()
2111 #endif
2112         call set_matrices
2113 #ifdef TIMING
2114         time_mat=time_mat+MPI_Wtime()-time01
2115 #endif
2116       endif
2117 cd      do i=1,nres-1
2118 cd        write (iout,*) 'i=',i
2119 cd        do k=1,3
2120 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2121 cd        enddo
2122 cd        do k=1,3
2123 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2124 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2125 cd        enddo
2126 cd      enddo
2127       t_eelecij=0.0d0
2128       ees=0.0D0
2129       evdw1=0.0D0
2130       eel_loc=0.0d0
2131       eello_turn3=0.0d0
2132       eello_turn4=0.0d0
2133       ind=0
2134       do i=1,nres
2135         num_cont_hb(i)=0
2136       enddo
2137 cd      print '(a)','Enter EELEC'
2138 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2139 c      call flush(iout)
2140       do i=1,nres
2141         gel_loc_loc(i)=0.0d0
2142         gcorr_loc(i)=0.0d0
2143       enddo
2144 c
2145 c
2146 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2147 C
2148 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2149 C
2150 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2151       do i=iturn3_start,iturn3_end
2152 c        if (i.le.1) cycle
2153 C        write(iout,*) "tu jest i",i
2154         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2155 C changes suggested by Ana to avoid out of bounds
2156 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2157 c     & .or.((i+4).gt.nres)
2158 c     & .or.((i-1).le.0)
2159 C end of changes by Ana
2160 C dobra zmiana wycofana
2161      &  .or. itype(i+2).eq.ntyp1
2162      &  .or. itype(i+3).eq.ntyp1) cycle
2163 C Adam: Instructions below will switch off existing interactions
2164 c        if(i.gt.1)then
2165 c          if(itype(i-1).eq.ntyp1)cycle
2166 c        end if
2167 c        if(i.LT.nres-3)then
2168 c          if (itype(i+4).eq.ntyp1) cycle
2169 c        end if
2170         dxi=dc(1,i)
2171         dyi=dc(2,i)
2172         dzi=dc(3,i)
2173         dx_normi=dc_norm(1,i)
2174         dy_normi=dc_norm(2,i)
2175         dz_normi=dc_norm(3,i)
2176         xmedi=c(1,i)+0.5d0*dxi
2177         ymedi=c(2,i)+0.5d0*dyi
2178         zmedi=c(3,i)+0.5d0*dzi
2179           xmedi=mod(xmedi,boxxsize)
2180           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2181           ymedi=mod(ymedi,boxysize)
2182           if (ymedi.lt.0) ymedi=ymedi+boxysize
2183           zmedi=mod(zmedi,boxzsize)
2184           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2185         num_conti=0
2186         call eelecij(i,i+2,ees,evdw1,eel_loc)
2187         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2188         num_cont_hb(i)=num_conti
2189       enddo
2190       do i=iturn4_start,iturn4_end
2191         if (i.lt.1) cycle
2192         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2193 C changes suggested by Ana to avoid out of bounds
2194 c     & .or.((i+5).gt.nres)
2195 c     & .or.((i-1).le.0)
2196 C end of changes suggested by Ana
2197      &    .or. itype(i+3).eq.ntyp1
2198      &    .or. itype(i+4).eq.ntyp1
2199 c     &    .or. itype(i+5).eq.ntyp1
2200 c     &    .or. itype(i).eq.ntyp1
2201 c     &    .or. itype(i-1).eq.ntyp1
2202      &                             ) cycle
2203         dxi=dc(1,i)
2204         dyi=dc(2,i)
2205         dzi=dc(3,i)
2206         dx_normi=dc_norm(1,i)
2207         dy_normi=dc_norm(2,i)
2208         dz_normi=dc_norm(3,i)
2209         xmedi=c(1,i)+0.5d0*dxi
2210         ymedi=c(2,i)+0.5d0*dyi
2211         zmedi=c(3,i)+0.5d0*dzi
2212 C Return atom into box, boxxsize is size of box in x dimension
2213 c  194   continue
2214 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2215 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2216 C Condition for being inside the proper box
2217 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2218 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2219 c        go to 194
2220 c        endif
2221 c  195   continue
2222 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2223 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2224 C Condition for being inside the proper box
2225 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2226 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2227 c        go to 195
2228 c        endif
2229 c  196   continue
2230 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2231 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2232 C Condition for being inside the proper box
2233 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2234 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2235 c        go to 196
2236 c        endif
2237           xmedi=mod(xmedi,boxxsize)
2238           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2239           ymedi=mod(ymedi,boxysize)
2240           if (ymedi.lt.0) ymedi=ymedi+boxysize
2241           zmedi=mod(zmedi,boxzsize)
2242           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2243
2244         num_conti=num_cont_hb(i)
2245 c        write(iout,*) "JESTEM W PETLI"
2246         call eelecij(i,i+3,ees,evdw1,eel_loc)
2247         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2248      &   call eturn4(i,eello_turn4)
2249         num_cont_hb(i)=num_conti
2250       enddo   ! i
2251 C Loop over all neighbouring boxes
2252 C      do xshift=-1,1
2253 C      do yshift=-1,1
2254 C      do zshift=-1,1
2255 c
2256 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2257 c
2258 CTU KURWA
2259       do i=iatel_s,iatel_e
2260 C        do i=75,75
2261 c        if (i.le.1) cycle
2262         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2263 C changes suggested by Ana to avoid out of bounds
2264 c     & .or.((i+2).gt.nres)
2265 c     & .or.((i-1).le.0)
2266 C end of changes by Ana
2267 c     &  .or. itype(i+2).eq.ntyp1
2268 c     &  .or. itype(i-1).eq.ntyp1
2269      &                ) cycle
2270         dxi=dc(1,i)
2271         dyi=dc(2,i)
2272         dzi=dc(3,i)
2273         dx_normi=dc_norm(1,i)
2274         dy_normi=dc_norm(2,i)
2275         dz_normi=dc_norm(3,i)
2276         xmedi=c(1,i)+0.5d0*dxi
2277         ymedi=c(2,i)+0.5d0*dyi
2278         zmedi=c(3,i)+0.5d0*dzi
2279           xmedi=mod(xmedi,boxxsize)
2280           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2281           ymedi=mod(ymedi,boxysize)
2282           if (ymedi.lt.0) ymedi=ymedi+boxysize
2283           zmedi=mod(zmedi,boxzsize)
2284           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2285 C          xmedi=xmedi+xshift*boxxsize
2286 C          ymedi=ymedi+yshift*boxysize
2287 C          zmedi=zmedi+zshift*boxzsize
2288
2289 C Return tom into box, boxxsize is size of box in x dimension
2290 c  164   continue
2291 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2292 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2293 C Condition for being inside the proper box
2294 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2295 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2296 c        go to 164
2297 c        endif
2298 c  165   continue
2299 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2300 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2301 C Condition for being inside the proper box
2302 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2303 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2304 c        go to 165
2305 c        endif
2306 c  166   continue
2307 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2308 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2309 cC Condition for being inside the proper box
2310 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2311 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2312 c        go to 166
2313 c        endif
2314
2315 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2316         num_conti=num_cont_hb(i)
2317 C I TU KURWA
2318         do j=ielstart(i),ielend(i)
2319 C          do j=16,17
2320 C          write (iout,*) i,j
2321 C         if (j.le.1) cycle
2322           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2323 C changes suggested by Ana to avoid out of bounds
2324 c     & .or.((j+2).gt.nres)
2325 c     & .or.((j-1).le.0)
2326 C end of changes by Ana
2327 c     & .or.itype(j+2).eq.ntyp1
2328 c     & .or.itype(j-1).eq.ntyp1
2329      &) cycle
2330           call eelecij(i,j,ees,evdw1,eel_loc)
2331         enddo ! j
2332         num_cont_hb(i)=num_conti
2333       enddo   ! i
2334 C     enddo   ! zshift
2335 C      enddo   ! yshift
2336 C      enddo   ! xshift
2337
2338 c      write (iout,*) "Number of loop steps in EELEC:",ind
2339 cd      do i=1,nres
2340 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2341 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2342 cd      enddo
2343 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2344 ccc      eel_loc=eel_loc+eello_turn3
2345 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2346       return
2347       end
2348 C-------------------------------------------------------------------------------
2349       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2350       implicit real*8 (a-h,o-z)
2351       include 'DIMENSIONS'
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       include 'COMMON.CONTACTS'
2364       include 'COMMON.TORSION'
2365       include 'COMMON.VECTORS'
2366       include 'COMMON.FFIELD'
2367       include 'COMMON.TIME1'
2368       include 'COMMON.SPLITELE'
2369       include 'COMMON.SHIELD'
2370       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2371      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2372       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2373      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2374      &    gmuij2(4),gmuji2(4)
2375       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2376      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2377      &    num_conti,j1,j2
2378 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2379 #ifdef MOMENT
2380       double precision scal_el /1.0d0/
2381 #else
2382       double precision scal_el /0.5d0/
2383 #endif
2384 C 12/13/98
2385 C 13-go grudnia roku pamietnego...
2386       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2387      &                   0.0d0,1.0d0,0.0d0,
2388      &                   0.0d0,0.0d0,1.0d0/
2389        integer xshift,yshift,zshift
2390 c          time00=MPI_Wtime()
2391 cd      write (iout,*) "eelecij",i,j
2392 c          ind=ind+1
2393           iteli=itel(i)
2394           itelj=itel(j)
2395           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2396           aaa=app(iteli,itelj)
2397           bbb=bpp(iteli,itelj)
2398           ael6i=ael6(iteli,itelj)
2399           ael3i=ael3(iteli,itelj)
2400           dxj=dc(1,j)
2401           dyj=dc(2,j)
2402           dzj=dc(3,j)
2403           dx_normj=dc_norm(1,j)
2404           dy_normj=dc_norm(2,j)
2405           dz_normj=dc_norm(3,j)
2406 C          xj=c(1,j)+0.5D0*dxj-xmedi
2407 C          yj=c(2,j)+0.5D0*dyj-ymedi
2408 C          zj=c(3,j)+0.5D0*dzj-zmedi
2409           xj=c(1,j)+0.5D0*dxj
2410           yj=c(2,j)+0.5D0*dyj
2411           zj=c(3,j)+0.5D0*dzj
2412           xj=mod(xj,boxxsize)
2413           if (xj.lt.0) xj=xj+boxxsize
2414           yj=mod(yj,boxysize)
2415           if (yj.lt.0) yj=yj+boxysize
2416           zj=mod(zj,boxzsize)
2417           if (zj.lt.0) zj=zj+boxzsize
2418           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2419       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2420       xj_safe=xj
2421       yj_safe=yj
2422       zj_safe=zj
2423       isubchap=0
2424       do xshift=-1,1
2425       do yshift=-1,1
2426       do zshift=-1,1
2427           xj=xj_safe+xshift*boxxsize
2428           yj=yj_safe+yshift*boxysize
2429           zj=zj_safe+zshift*boxzsize
2430           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2431           if(dist_temp.lt.dist_init) then
2432             dist_init=dist_temp
2433             xj_temp=xj
2434             yj_temp=yj
2435             zj_temp=zj
2436             isubchap=1
2437           endif
2438        enddo
2439        enddo
2440        enddo
2441        if (isubchap.eq.1) then
2442           xj=xj_temp-xmedi
2443           yj=yj_temp-ymedi
2444           zj=zj_temp-zmedi
2445        else
2446           xj=xj_safe-xmedi
2447           yj=yj_safe-ymedi
2448           zj=zj_safe-zmedi
2449        endif
2450 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2451 c  174   continue
2452 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2453 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2454 C Condition for being inside the proper box
2455 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2456 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2457 c        go to 174
2458 c        endif
2459 c  175   continue
2460 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2461 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2462 C Condition for being inside the proper box
2463 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2464 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2465 c        go to 175
2466 c        endif
2467 c  176   continue
2468 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2469 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2470 C Condition for being inside the proper box
2471 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2472 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2473 c        go to 176
2474 c        endif
2475 C        endif !endPBC condintion
2476 C        xj=xj-xmedi
2477 C        yj=yj-ymedi
2478 C        zj=zj-zmedi
2479           rij=xj*xj+yj*yj+zj*zj
2480
2481             sss=sscale(sqrt(rij))
2482             sssgrad=sscagrad(sqrt(rij))
2483 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2484 c     &       " rlamb",rlamb," sss",sss
2485 c            if (sss.gt.0.0d0) then
2486           rrmij=1.0D0/rij
2487           rij=dsqrt(rij)
2488           rmij=1.0D0/rij
2489           r3ij=rrmij*rmij
2490           r6ij=r3ij*r3ij
2491           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2492           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2493           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2494           fac=cosa-3.0D0*cosb*cosg
2495           ev1=aaa*r6ij*r6ij
2496 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2497           if (j.eq.i+2) ev1=scal_el*ev1
2498           ev2=bbb*r6ij
2499           fac3=ael6i*r6ij
2500           fac4=ael3i*r3ij
2501           evdwij=(ev1+ev2)
2502           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2503           el2=fac4*fac
2504 C MARYSIA
2505 C          eesij=(el1+el2)
2506 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2507           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2508           if (shield_mode.gt.0) then
2509 C          fac_shield(i)=0.4
2510 C          fac_shield(j)=0.6
2511           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2512           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2513           eesij=(el1+el2)
2514           ees=ees+eesij
2515           else
2516           fac_shield(i)=1.0
2517           fac_shield(j)=1.0
2518           eesij=(el1+el2)
2519           ees=ees+eesij
2520           endif
2521           evdw1=evdw1+evdwij*sss
2522 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2523 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2524 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2525 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2526
2527           if (energy_dec) then
2528               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2529      &'evdw1',i,j,evdwij
2530      &,iteli,itelj,aaa,evdw1,sss
2531               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2532      &fac_shield(i),fac_shield(j)
2533           endif
2534
2535 C
2536 C Calculate contributions to the Cartesian gradient.
2537 C
2538 #ifdef SPLITELE
2539           facvdw=-6*rrmij*(ev1+evdwij)*sss
2540           facel=-3*rrmij*(el1+eesij)
2541           fac1=fac
2542           erij(1)=xj*rmij
2543           erij(2)=yj*rmij
2544           erij(3)=zj*rmij
2545
2546 *
2547 * Radial derivatives. First process both termini of the fragment (i,j)
2548 *
2549           if (calc_grad) then
2550           ggg(1)=facel*xj
2551           ggg(2)=facel*yj
2552           ggg(3)=facel*zj
2553           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2554      &  (shield_mode.gt.0)) then
2555 C          print *,i,j
2556           do ilist=1,ishield_list(i)
2557            iresshield=shield_list(ilist,i)
2558            do k=1,3
2559            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2560      &      *2.0
2561            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2562      &              rlocshield
2563      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2564             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2565 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2566 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2567 C             if (iresshield.gt.i) then
2568 C               do ishi=i+1,iresshield-1
2569 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2570 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2571 C
2572 C              enddo
2573 C             else
2574 C               do ishi=iresshield,i
2575 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2576 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2577 C
2578 C               enddo
2579 C              endif
2580            enddo
2581           enddo
2582           do ilist=1,ishield_list(j)
2583            iresshield=shield_list(ilist,j)
2584            do k=1,3
2585            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2586      &     *2.0
2587            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2588      &              rlocshield
2589      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2590            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2591
2592 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2593 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2594 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2595 C             if (iresshield.gt.j) then
2596 C               do ishi=j+1,iresshield-1
2597 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2598 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2599 C
2600 C               enddo
2601 C            else
2602 C               do ishi=iresshield,j
2603 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2604 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2605 C               enddo
2606 C              endif
2607            enddo
2608           enddo
2609
2610           do k=1,3
2611             gshieldc(k,i)=gshieldc(k,i)+
2612      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2613             gshieldc(k,j)=gshieldc(k,j)+
2614      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2615             gshieldc(k,i-1)=gshieldc(k,i-1)+
2616      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2617             gshieldc(k,j-1)=gshieldc(k,j-1)+
2618      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2619
2620            enddo
2621            endif
2622 c          do k=1,3
2623 c            ghalf=0.5D0*ggg(k)
2624 c            gelc(k,i)=gelc(k,i)+ghalf
2625 c            gelc(k,j)=gelc(k,j)+ghalf
2626 c          enddo
2627 c 9/28/08 AL Gradient compotents will be summed only at the end
2628 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2629           do k=1,3
2630             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2631 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2632             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2633 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2634 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2635 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2636 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2637 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2638           enddo
2639 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2640
2641 *
2642 * Loop over residues i+1 thru j-1.
2643 *
2644 cgrad          do k=i+1,j-1
2645 cgrad            do l=1,3
2646 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2647 cgrad            enddo
2648 cgrad          enddo
2649           if (sss.gt.0.0) then
2650           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2651           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2652           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2653           else
2654           ggg(1)=0.0
2655           ggg(2)=0.0
2656           ggg(3)=0.0
2657           endif
2658 c          do k=1,3
2659 c            ghalf=0.5D0*ggg(k)
2660 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2661 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2662 c          enddo
2663 c 9/28/08 AL Gradient compotents will be summed only at the end
2664           do k=1,3
2665             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2666             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2667           enddo
2668 *
2669 * Loop over residues i+1 thru j-1.
2670 *
2671 cgrad          do k=i+1,j-1
2672 cgrad            do l=1,3
2673 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2674 cgrad            enddo
2675 cgrad          enddo
2676           endif ! calc_grad
2677 #else
2678 C MARYSIA
2679           facvdw=(ev1+evdwij)*sss
2680           facel=(el1+eesij)
2681           fac1=fac
2682           fac=-3*rrmij*(facvdw+facvdw+facel)
2683           erij(1)=xj*rmij
2684           erij(2)=yj*rmij
2685           erij(3)=zj*rmij
2686 *
2687 * Radial derivatives. First process both termini of the fragment (i,j)
2688 *
2689           if (calc_grad) then
2690           ggg(1)=fac*xj
2691 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2692           ggg(2)=fac*yj
2693 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2694           ggg(3)=fac*zj
2695 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2696 c          do k=1,3
2697 c            ghalf=0.5D0*ggg(k)
2698 c            gelc(k,i)=gelc(k,i)+ghalf
2699 c            gelc(k,j)=gelc(k,j)+ghalf
2700 c          enddo
2701 c 9/28/08 AL Gradient compotents will be summed only at the end
2702           do k=1,3
2703             gelc_long(k,j)=gelc(k,j)+ggg(k)
2704             gelc_long(k,i)=gelc(k,i)-ggg(k)
2705           enddo
2706 *
2707 * Loop over residues i+1 thru j-1.
2708 *
2709 cgrad          do k=i+1,j-1
2710 cgrad            do l=1,3
2711 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2712 cgrad            enddo
2713 cgrad          enddo
2714 c 9/28/08 AL Gradient compotents will be summed only at the end
2715           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2716           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2717           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2718           do k=1,3
2719             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2720             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2721           enddo
2722           endif ! calc_grad
2723 #endif
2724 *
2725 * Angular part
2726 *
2727           if (calc_grad) then
2728           ecosa=2.0D0*fac3*fac1+fac4
2729           fac4=-3.0D0*fac4
2730           fac3=-6.0D0*fac3
2731           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2732           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2733           do k=1,3
2734             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2735             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2736           enddo
2737 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2738 cd   &          (dcosg(k),k=1,3)
2739           do k=1,3
2740             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2741      &      fac_shield(i)**2*fac_shield(j)**2
2742           enddo
2743 c          do k=1,3
2744 c            ghalf=0.5D0*ggg(k)
2745 c            gelc(k,i)=gelc(k,i)+ghalf
2746 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2747 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2748 c            gelc(k,j)=gelc(k,j)+ghalf
2749 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2750 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2751 c          enddo
2752 cgrad          do k=i+1,j-1
2753 cgrad            do l=1,3
2754 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2755 cgrad            enddo
2756 cgrad          enddo
2757 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2758           do k=1,3
2759             gelc(k,i)=gelc(k,i)
2760      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2761      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2762      &           *fac_shield(i)**2*fac_shield(j)**2
2763             gelc(k,j)=gelc(k,j)
2764      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2765      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2766      &           *fac_shield(i)**2*fac_shield(j)**2
2767             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2768             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2769           enddo
2770 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2771
2772 C MARYSIA
2773 c          endif !sscale
2774           endif ! calc_grad
2775           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2776      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2777      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2778 C
2779 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2780 C   energy of a peptide unit is assumed in the form of a second-order
2781 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2782 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2783 C   are computed for EVERY pair of non-contiguous peptide groups.
2784 C
2785
2786           if (j.lt.nres-1) then
2787             j1=j+1
2788             j2=j-1
2789           else
2790             j1=j-1
2791             j2=j-2
2792           endif
2793           kkk=0
2794           lll=0
2795           do k=1,2
2796             do l=1,2
2797               kkk=kkk+1
2798               muij(kkk)=mu(k,i)*mu(l,j)
2799 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2800 #ifdef NEWCORR
2801              if (calc_grad) then
2802              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2803 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2804              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2805              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2806 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2807              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2808              endif
2809 #endif
2810             enddo
2811           enddo
2812 #ifdef DEBUG
2813           write (iout,*) 'EELEC: i',i,' j',j
2814           write (iout,*) 'j',j,' j1',j1,' j2',j2
2815           write(iout,*) 'muij',muij
2816           write (iout,*) "uy",uy(:,i)
2817           write (iout,*) "uz",uz(:,j)
2818           write (iout,*) "erij",erij
2819 #endif
2820           ury=scalar(uy(1,i),erij)
2821           urz=scalar(uz(1,i),erij)
2822           vry=scalar(uy(1,j),erij)
2823           vrz=scalar(uz(1,j),erij)
2824           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2825           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2826           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2827           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2828           fac=dsqrt(-ael6i)*r3ij
2829           a22=a22*fac
2830           a23=a23*fac
2831           a32=a32*fac
2832           a33=a33*fac
2833 cd          write (iout,'(4i5,4f10.5)')
2834 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2835 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2836 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2837 cd     &      uy(:,j),uz(:,j)
2838 cd          write (iout,'(4f10.5)')
2839 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2840 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2841 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2842 cd           write (iout,'(9f10.5/)')
2843 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2844 C Derivatives of the elements of A in virtual-bond vectors
2845           if (calc_grad) then
2846           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2847           do k=1,3
2848             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2849             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2850             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2851             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2852             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2853             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2854             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2855             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2856             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2857             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2858             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2859             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2860           enddo
2861 C Compute radial contributions to the gradient
2862           facr=-3.0d0*rrmij
2863           a22der=a22*facr
2864           a23der=a23*facr
2865           a32der=a32*facr
2866           a33der=a33*facr
2867           agg(1,1)=a22der*xj
2868           agg(2,1)=a22der*yj
2869           agg(3,1)=a22der*zj
2870           agg(1,2)=a23der*xj
2871           agg(2,2)=a23der*yj
2872           agg(3,2)=a23der*zj
2873           agg(1,3)=a32der*xj
2874           agg(2,3)=a32der*yj
2875           agg(3,3)=a32der*zj
2876           agg(1,4)=a33der*xj
2877           agg(2,4)=a33der*yj
2878           agg(3,4)=a33der*zj
2879 C Add the contributions coming from er
2880           fac3=-3.0d0*fac
2881           do k=1,3
2882             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2883             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2884             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2885             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2886           enddo
2887           do k=1,3
2888 C Derivatives in DC(i)
2889 cgrad            ghalf1=0.5d0*agg(k,1)
2890 cgrad            ghalf2=0.5d0*agg(k,2)
2891 cgrad            ghalf3=0.5d0*agg(k,3)
2892 cgrad            ghalf4=0.5d0*agg(k,4)
2893             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2894      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2895             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2896      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2897             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2898      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2899             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2900      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2901 C Derivatives in DC(i+1)
2902             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2903      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2904             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2905      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2906             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2907      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2908             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2909      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2910 C Derivatives in DC(j)
2911             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2912      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2913             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2914      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2915             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2916      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2917             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2918      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2919 C Derivatives in DC(j+1) or DC(nres-1)
2920             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2921      &      -3.0d0*vryg(k,3)*ury)
2922             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2923      &      -3.0d0*vrzg(k,3)*ury)
2924             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2925      &      -3.0d0*vryg(k,3)*urz)
2926             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2927      &      -3.0d0*vrzg(k,3)*urz)
2928 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2929 cgrad              do l=1,4
2930 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2931 cgrad              enddo
2932 cgrad            endif
2933           enddo
2934           endif ! calc_grad
2935           acipa(1,1)=a22
2936           acipa(1,2)=a23
2937           acipa(2,1)=a32
2938           acipa(2,2)=a33
2939           a22=-a22
2940           a23=-a23
2941           if (calc_grad) then
2942           do l=1,2
2943             do k=1,3
2944               agg(k,l)=-agg(k,l)
2945               aggi(k,l)=-aggi(k,l)
2946               aggi1(k,l)=-aggi1(k,l)
2947               aggj(k,l)=-aggj(k,l)
2948               aggj1(k,l)=-aggj1(k,l)
2949             enddo
2950           enddo
2951           endif ! calc_grad
2952           if (j.lt.nres-1) then
2953             a22=-a22
2954             a32=-a32
2955             do l=1,3,2
2956               do k=1,3
2957                 agg(k,l)=-agg(k,l)
2958                 aggi(k,l)=-aggi(k,l)
2959                 aggi1(k,l)=-aggi1(k,l)
2960                 aggj(k,l)=-aggj(k,l)
2961                 aggj1(k,l)=-aggj1(k,l)
2962               enddo
2963             enddo
2964           else
2965             a22=-a22
2966             a23=-a23
2967             a32=-a32
2968             a33=-a33
2969             do l=1,4
2970               do k=1,3
2971                 agg(k,l)=-agg(k,l)
2972                 aggi(k,l)=-aggi(k,l)
2973                 aggi1(k,l)=-aggi1(k,l)
2974                 aggj(k,l)=-aggj(k,l)
2975                 aggj1(k,l)=-aggj1(k,l)
2976               enddo
2977             enddo
2978           endif
2979           ENDIF ! WCORR
2980           IF (wel_loc.gt.0.0d0) THEN
2981 C Contribution to the local-electrostatic energy coming from the i-j pair
2982           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2983      &     +a33*muij(4)
2984 #ifdef DEBUG
2985           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2986      &     " a33",a33
2987           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2988      &     " wel_loc",wel_loc
2989 #endif
2990           if (shield_mode.eq.0) then
2991            fac_shield(i)=1.0
2992            fac_shield(j)=1.0
2993 C          else
2994 C           fac_shield(i)=0.4
2995 C           fac_shield(j)=0.6
2996           endif
2997           eel_loc_ij=eel_loc_ij
2998      &    *fac_shield(i)*fac_shield(j)
2999           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3000      &            'eelloc',i,j,eel_loc_ij
3001 c           if (eel_loc_ij.ne.0)
3002 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3003 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3004
3005           eel_loc=eel_loc+eel_loc_ij
3006 C Now derivative over eel_loc
3007           if (calc_grad) then
3008           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3009      &  (shield_mode.gt.0)) then
3010 C          print *,i,j
3011
3012           do ilist=1,ishield_list(i)
3013            iresshield=shield_list(ilist,i)
3014            do k=1,3
3015            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3016      &                                          /fac_shield(i)
3017 C     &      *2.0
3018            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3019      &              rlocshield
3020      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3021             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3022      &      +rlocshield
3023            enddo
3024           enddo
3025           do ilist=1,ishield_list(j)
3026            iresshield=shield_list(ilist,j)
3027            do k=1,3
3028            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3029      &                                       /fac_shield(j)
3030 C     &     *2.0
3031            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3032      &              rlocshield
3033      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3034            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3035      &             +rlocshield
3036
3037            enddo
3038           enddo
3039
3040           do k=1,3
3041             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3042      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3043             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3044      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3045             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3046      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3047             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3048      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3049            enddo
3050            endif
3051
3052
3053 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3054 c     &                     ' eel_loc_ij',eel_loc_ij
3055 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3056 C Calculate patrial derivative for theta angle
3057 #ifdef NEWCORR
3058          geel_loc_ij=(a22*gmuij1(1)
3059      &     +a23*gmuij1(2)
3060      &     +a32*gmuij1(3)
3061      &     +a33*gmuij1(4))
3062      &    *fac_shield(i)*fac_shield(j)
3063 c         write(iout,*) "derivative over thatai"
3064 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3065 c     &   a33*gmuij1(4)
3066          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3067      &      geel_loc_ij*wel_loc
3068 c         write(iout,*) "derivative over thatai-1"
3069 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3070 c     &   a33*gmuij2(4)
3071          geel_loc_ij=
3072      &     a22*gmuij2(1)
3073      &     +a23*gmuij2(2)
3074      &     +a32*gmuij2(3)
3075      &     +a33*gmuij2(4)
3076          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3077      &      geel_loc_ij*wel_loc
3078      &    *fac_shield(i)*fac_shield(j)
3079
3080 c  Derivative over j residue
3081          geel_loc_ji=a22*gmuji1(1)
3082      &     +a23*gmuji1(2)
3083      &     +a32*gmuji1(3)
3084      &     +a33*gmuji1(4)
3085 c         write(iout,*) "derivative over thataj"
3086 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3087 c     &   a33*gmuji1(4)
3088
3089         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3090      &      geel_loc_ji*wel_loc
3091      &    *fac_shield(i)*fac_shield(j)
3092
3093          geel_loc_ji=
3094      &     +a22*gmuji2(1)
3095      &     +a23*gmuji2(2)
3096      &     +a32*gmuji2(3)
3097      &     +a33*gmuji2(4)
3098 c         write(iout,*) "derivative over thataj-1"
3099 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3100 c     &   a33*gmuji2(4)
3101          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3102      &      geel_loc_ji*wel_loc
3103      &    *fac_shield(i)*fac_shield(j)
3104 #endif
3105 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3106
3107 C Partial derivatives in virtual-bond dihedral angles gamma
3108           if (i.gt.1)
3109      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3110      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3111      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3112      &    *fac_shield(i)*fac_shield(j)
3113
3114           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3115      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3116      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3117      &    *fac_shield(i)*fac_shield(j)
3118 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3119           do l=1,3
3120             ggg(l)=(agg(l,1)*muij(1)+
3121      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3122      &    *fac_shield(i)*fac_shield(j)
3123             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3124             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3125 cgrad            ghalf=0.5d0*ggg(l)
3126 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3127 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3128           enddo
3129 cgrad          do k=i+1,j2
3130 cgrad            do l=1,3
3131 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3132 cgrad            enddo
3133 cgrad          enddo
3134 C Remaining derivatives of eello
3135           do l=1,3
3136             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3137      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3138      &    *fac_shield(i)*fac_shield(j)
3139
3140             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3141      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3142      &    *fac_shield(i)*fac_shield(j)
3143
3144             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3145      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3146      &    *fac_shield(i)*fac_shield(j)
3147
3148             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3149      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3150      &    *fac_shield(i)*fac_shield(j)
3151
3152           enddo
3153           endif ! calc_grad
3154           ENDIF
3155
3156
3157 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3158 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3159           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3160      &       .and. num_conti.le.maxconts) then
3161 c            write (iout,*) i,j," entered corr"
3162 C
3163 C Calculate the contact function. The ith column of the array JCONT will
3164 C contain the numbers of atoms that make contacts with the atom I (of numbers
3165 C greater than I). The arrays FACONT and GACONT will contain the values of
3166 C the contact function and its derivative.
3167 c           r0ij=1.02D0*rpp(iteli,itelj)
3168 c           r0ij=1.11D0*rpp(iteli,itelj)
3169             r0ij=2.20D0*rpp(iteli,itelj)
3170 c           r0ij=1.55D0*rpp(iteli,itelj)
3171             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3172             if (fcont.gt.0.0D0) then
3173               num_conti=num_conti+1
3174               if (num_conti.gt.maxconts) then
3175                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3176      &                         ' will skip next contacts for this conf.'
3177               else
3178                 jcont_hb(num_conti,i)=j
3179 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3180 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3181                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3182      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3183 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3184 C  terms.
3185                 d_cont(num_conti,i)=rij
3186 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3187 C     --- Electrostatic-interaction matrix ---
3188                 a_chuj(1,1,num_conti,i)=a22
3189                 a_chuj(1,2,num_conti,i)=a23
3190                 a_chuj(2,1,num_conti,i)=a32
3191                 a_chuj(2,2,num_conti,i)=a33
3192 C     --- Gradient of rij
3193                 if (calc_grad) then
3194                 do kkk=1,3
3195                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3196                 enddo
3197                 kkll=0
3198                 do k=1,2
3199                   do l=1,2
3200                     kkll=kkll+1
3201                     do m=1,3
3202                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3203                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3204                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3205                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3206                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3207                     enddo
3208                   enddo
3209                 enddo
3210                 endif ! calc_grad
3211                 ENDIF
3212                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3213 C Calculate contact energies
3214                 cosa4=4.0D0*cosa
3215                 wij=cosa-3.0D0*cosb*cosg
3216                 cosbg1=cosb+cosg
3217                 cosbg2=cosb-cosg
3218 c               fac3=dsqrt(-ael6i)/r0ij**3
3219                 fac3=dsqrt(-ael6i)*r3ij
3220 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3221                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3222                 if (ees0tmp.gt.0) then
3223                   ees0pij=dsqrt(ees0tmp)
3224                 else
3225                   ees0pij=0
3226                 endif
3227 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3228                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3229                 if (ees0tmp.gt.0) then
3230                   ees0mij=dsqrt(ees0tmp)
3231                 else
3232                   ees0mij=0
3233                 endif
3234 c               ees0mij=0.0D0
3235                 if (shield_mode.eq.0) then
3236                 fac_shield(i)=1.0d0
3237                 fac_shield(j)=1.0d0
3238                 else
3239                 ees0plist(num_conti,i)=j
3240 C                fac_shield(i)=0.4d0
3241 C                fac_shield(j)=0.6d0
3242                 endif
3243                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3244      &          *fac_shield(i)*fac_shield(j)
3245                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3246      &          *fac_shield(i)*fac_shield(j)
3247 C Diagnostics. Comment out or remove after debugging!
3248 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3249 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3250 c               ees0m(num_conti,i)=0.0D0
3251 C End diagnostics.
3252 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3253 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3254 C Angular derivatives of the contact function
3255
3256                 ees0pij1=fac3/ees0pij
3257                 ees0mij1=fac3/ees0mij
3258                 fac3p=-3.0D0*fac3*rrmij
3259                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3260                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3261 c               ees0mij1=0.0D0
3262                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3263                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3264                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3265                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3266                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3267                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3268                 ecosap=ecosa1+ecosa2
3269                 ecosbp=ecosb1+ecosb2
3270                 ecosgp=ecosg1+ecosg2
3271                 ecosam=ecosa1-ecosa2
3272                 ecosbm=ecosb1-ecosb2
3273                 ecosgm=ecosg1-ecosg2
3274 C Diagnostics
3275 c               ecosap=ecosa1
3276 c               ecosbp=ecosb1
3277 c               ecosgp=ecosg1
3278 c               ecosam=0.0D0
3279 c               ecosbm=0.0D0
3280 c               ecosgm=0.0D0
3281 C End diagnostics
3282                 facont_hb(num_conti,i)=fcont
3283
3284                 if (calc_grad) then
3285                 fprimcont=fprimcont/rij
3286 cd              facont_hb(num_conti,i)=1.0D0
3287 C Following line is for diagnostics.
3288 cd              fprimcont=0.0D0
3289                 do k=1,3
3290                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3291                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3292                 enddo
3293                 do k=1,3
3294                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3295                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3296                 enddo
3297                 gggp(1)=gggp(1)+ees0pijp*xj
3298                 gggp(2)=gggp(2)+ees0pijp*yj
3299                 gggp(3)=gggp(3)+ees0pijp*zj
3300                 gggm(1)=gggm(1)+ees0mijp*xj
3301                 gggm(2)=gggm(2)+ees0mijp*yj
3302                 gggm(3)=gggm(3)+ees0mijp*zj
3303 C Derivatives due to the contact function
3304                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3305                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3306                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3307                 do k=1,3
3308 c
3309 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3310 c          following the change of gradient-summation algorithm.
3311 c
3312 cgrad                  ghalfp=0.5D0*gggp(k)
3313 cgrad                  ghalfm=0.5D0*gggm(k)
3314                   gacontp_hb1(k,num_conti,i)=!ghalfp
3315      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3316      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3317      &          *fac_shield(i)*fac_shield(j)
3318
3319                   gacontp_hb2(k,num_conti,i)=!ghalfp
3320      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3321      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3322      &          *fac_shield(i)*fac_shield(j)
3323
3324                   gacontp_hb3(k,num_conti,i)=gggp(k)
3325      &          *fac_shield(i)*fac_shield(j)
3326
3327                   gacontm_hb1(k,num_conti,i)=!ghalfm
3328      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3329      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3330      &          *fac_shield(i)*fac_shield(j)
3331
3332                   gacontm_hb2(k,num_conti,i)=!ghalfm
3333      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3334      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3335      &          *fac_shield(i)*fac_shield(j)
3336
3337                   gacontm_hb3(k,num_conti,i)=gggm(k)
3338      &          *fac_shield(i)*fac_shield(j)
3339
3340                 enddo
3341 C Diagnostics. Comment out or remove after debugging!
3342 cdiag           do k=1,3
3343 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3344 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3345 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3346 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3347 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3348 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3349 cdiag           enddo
3350
3351                  endif ! calc_grad
3352
3353               ENDIF ! wcorr
3354               endif  ! num_conti.le.maxconts
3355             endif  ! fcont.gt.0
3356           endif    ! j.gt.i+1
3357           if (calc_grad) then
3358           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3359             do k=1,4
3360               do l=1,3
3361                 ghalf=0.5d0*agg(l,k)
3362                 aggi(l,k)=aggi(l,k)+ghalf
3363                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3364                 aggj(l,k)=aggj(l,k)+ghalf
3365               enddo
3366             enddo
3367             if (j.eq.nres-1 .and. i.lt.j-2) then
3368               do k=1,4
3369                 do l=1,3
3370                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3371                 enddo
3372               enddo
3373             endif
3374           endif
3375           endif ! calc_grad
3376 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3377       return
3378       end
3379 C-----------------------------------------------------------------------------
3380       subroutine eturn3(i,eello_turn3)
3381 C Third- and fourth-order contributions from turns
3382       implicit real*8 (a-h,o-z)
3383       include 'DIMENSIONS'
3384       include 'COMMON.IOUNITS'
3385       include 'COMMON.GEO'
3386       include 'COMMON.VAR'
3387       include 'COMMON.LOCAL'
3388       include 'COMMON.CHAIN'
3389       include 'COMMON.DERIV'
3390       include 'COMMON.INTERACT'
3391       include 'COMMON.CONTACTS'
3392       include 'COMMON.TORSION'
3393       include 'COMMON.VECTORS'
3394       include 'COMMON.FFIELD'
3395       include 'COMMON.CONTROL'
3396       include 'COMMON.SHIELD'
3397       dimension ggg(3)
3398       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3399      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3400      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3401      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3402      &  auxgmat2(2,2),auxgmatt2(2,2)
3403       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3404      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3405       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3406      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3407      &    num_conti,j1,j2
3408       j=i+2
3409 c      write (iout,*) "eturn3",i,j,j1,j2
3410       a_temp(1,1)=a22
3411       a_temp(1,2)=a23
3412       a_temp(2,1)=a32
3413       a_temp(2,2)=a33
3414 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3415 C
3416 C               Third-order contributions
3417 C
3418 C                 (i+2)o----(i+3)
3419 C                      | |
3420 C                      | |
3421 C                 (i+1)o----i
3422 C
3423 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3424 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3425         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3426 c auxalary matices for theta gradient
3427 c auxalary matrix for i+1 and constant i+2
3428         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3429 c auxalary matrix for i+2 and constant i+1
3430         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3431         call transpose2(auxmat(1,1),auxmat1(1,1))
3432         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3433         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3434         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3435         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3436         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3437         if (shield_mode.eq.0) then
3438         fac_shield(i)=1.0
3439         fac_shield(j)=1.0
3440 C        else
3441 C        fac_shield(i)=0.4
3442 C        fac_shield(j)=0.6
3443         endif
3444         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3445      &  *fac_shield(i)*fac_shield(j)
3446         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3447      &  *fac_shield(i)*fac_shield(j)
3448         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3449      &    eello_t3
3450         if (calc_grad) then
3451 C#ifdef NEWCORR
3452 C Derivatives in theta
3453         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3454      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3455      &   *fac_shield(i)*fac_shield(j)
3456         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3457      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3458      &   *fac_shield(i)*fac_shield(j)
3459 C#endif
3460
3461 C Derivatives in shield mode
3462           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3463      &  (shield_mode.gt.0)) then
3464 C          print *,i,j
3465
3466           do ilist=1,ishield_list(i)
3467            iresshield=shield_list(ilist,i)
3468            do k=1,3
3469            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3470 C     &      *2.0
3471            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3472      &              rlocshield
3473      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3474             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3475      &      +rlocshield
3476            enddo
3477           enddo
3478           do ilist=1,ishield_list(j)
3479            iresshield=shield_list(ilist,j)
3480            do k=1,3
3481            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3482 C     &     *2.0
3483            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3484      &              rlocshield
3485      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3486            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3487      &             +rlocshield
3488
3489            enddo
3490           enddo
3491
3492           do k=1,3
3493             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3494      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3495             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3496      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3497             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3498      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3499             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3500      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3501            enddo
3502            endif
3503
3504 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3505 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3506 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3507 cd     &    ' eello_turn3_num',4*eello_turn3_num
3508 C Derivatives in gamma(i)
3509         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3510         call transpose2(auxmat2(1,1),auxmat3(1,1))
3511         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3512         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3513      &   *fac_shield(i)*fac_shield(j)
3514 C Derivatives in gamma(i+1)
3515         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3516         call transpose2(auxmat2(1,1),auxmat3(1,1))
3517         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3518         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3519      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3520      &   *fac_shield(i)*fac_shield(j)
3521 C Cartesian derivatives
3522         do l=1,3
3523 c            ghalf1=0.5d0*agg(l,1)
3524 c            ghalf2=0.5d0*agg(l,2)
3525 c            ghalf3=0.5d0*agg(l,3)
3526 c            ghalf4=0.5d0*agg(l,4)
3527           a_temp(1,1)=aggi(l,1)!+ghalf1
3528           a_temp(1,2)=aggi(l,2)!+ghalf2
3529           a_temp(2,1)=aggi(l,3)!+ghalf3
3530           a_temp(2,2)=aggi(l,4)!+ghalf4
3531           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3532           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3533      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3534      &   *fac_shield(i)*fac_shield(j)
3535
3536           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3537           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3538           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3539           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3540           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3541           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3542      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3543      &   *fac_shield(i)*fac_shield(j)
3544           a_temp(1,1)=aggj(l,1)!+ghalf1
3545           a_temp(1,2)=aggj(l,2)!+ghalf2
3546           a_temp(2,1)=aggj(l,3)!+ghalf3
3547           a_temp(2,2)=aggj(l,4)!+ghalf4
3548           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3549           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3550      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3551      &   *fac_shield(i)*fac_shield(j)
3552           a_temp(1,1)=aggj1(l,1)
3553           a_temp(1,2)=aggj1(l,2)
3554           a_temp(2,1)=aggj1(l,3)
3555           a_temp(2,2)=aggj1(l,4)
3556           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3557           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3558      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3559      &   *fac_shield(i)*fac_shield(j)
3560         enddo
3561
3562         endif ! calc_grad
3563
3564       return
3565       end
3566 C-------------------------------------------------------------------------------
3567       subroutine eturn4(i,eello_turn4)
3568 C Third- and fourth-order contributions from turns
3569       implicit real*8 (a-h,o-z)
3570       include 'DIMENSIONS'
3571       include 'COMMON.IOUNITS'
3572       include 'COMMON.GEO'
3573       include 'COMMON.VAR'
3574       include 'COMMON.LOCAL'
3575       include 'COMMON.CHAIN'
3576       include 'COMMON.DERIV'
3577       include 'COMMON.INTERACT'
3578       include 'COMMON.CONTACTS'
3579       include 'COMMON.TORSION'
3580       include 'COMMON.VECTORS'
3581       include 'COMMON.FFIELD'
3582       include 'COMMON.CONTROL'
3583       include 'COMMON.SHIELD'
3584       dimension ggg(3)
3585       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3586      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3587      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3588      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3589      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3590      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3591      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3592       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3593      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3594       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3595      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3596      &    num_conti,j1,j2
3597       j=i+3
3598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3599 C
3600 C               Fourth-order contributions
3601 C
3602 C                 (i+3)o----(i+4)
3603 C                     /  |
3604 C               (i+2)o   |
3605 C                     \  |
3606 C                 (i+1)o----i
3607 C
3608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3609 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3610 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3611 c        write(iout,*)"WCHODZE W PROGRAM"
3612         a_temp(1,1)=a22
3613         a_temp(1,2)=a23
3614         a_temp(2,1)=a32
3615         a_temp(2,2)=a33
3616         iti1=itype2loc(itype(i+1))
3617         iti2=itype2loc(itype(i+2))
3618         iti3=itype2loc(itype(i+3))
3619 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3620         call transpose2(EUg(1,1,i+1),e1t(1,1))
3621         call transpose2(Eug(1,1,i+2),e2t(1,1))
3622         call transpose2(Eug(1,1,i+3),e3t(1,1))
3623 C Ematrix derivative in theta
3624         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3625         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3626         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3627         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3628 c       eta1 in derivative theta
3629         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3630         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3631 c       auxgvec is derivative of Ub2 so i+3 theta
3632         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3633 c       auxalary matrix of E i+1
3634         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3635 c        s1=0.0
3636 c        gs1=0.0
3637         s1=scalar2(b1(1,i+2),auxvec(1))
3638 c derivative of theta i+2 with constant i+3
3639         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3640 c derivative of theta i+2 with constant i+2
3641         gs32=scalar2(b1(1,i+2),auxgvec(1))
3642 c derivative of E matix in theta of i+1
3643         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3644
3645         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3646 c       ea31 in derivative theta
3647         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3648         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3649 c auxilary matrix auxgvec of Ub2 with constant E matirx
3650         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3651 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3652         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3653
3654 c        s2=0.0
3655 c        gs2=0.0
3656         s2=scalar2(b1(1,i+1),auxvec(1))
3657 c derivative of theta i+1 with constant i+3
3658         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3659 c derivative of theta i+2 with constant i+1
3660         gs21=scalar2(b1(1,i+1),auxgvec(1))
3661 c derivative of theta i+3 with constant i+1
3662         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3663 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3664 c     &  gtb1(1,i+1)
3665         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3666 c two derivatives over diffetent matrices
3667 c gtae3e2 is derivative over i+3
3668         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3669 c ae3gte2 is derivative over i+2
3670         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3671         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3672 c three possible derivative over theta E matices
3673 c i+1
3674         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3675 c i+2
3676         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3677 c i+3
3678         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3679         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3680
3681         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3682         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3683         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3684         if (shield_mode.eq.0) then
3685         fac_shield(i)=1.0
3686         fac_shield(j)=1.0
3687 C        else
3688 C        fac_shield(i)=0.6
3689 C        fac_shield(j)=0.4
3690         endif
3691         eello_turn4=eello_turn4-(s1+s2+s3)
3692      &  *fac_shield(i)*fac_shield(j)
3693         eello_t4=-(s1+s2+s3)
3694      &  *fac_shield(i)*fac_shield(j)
3695 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3696         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3697      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3698 C Now derivative over shield:
3699           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3700      &  (shield_mode.gt.0)) then
3701 C          print *,i,j
3702
3703           do ilist=1,ishield_list(i)
3704            iresshield=shield_list(ilist,i)
3705            do k=1,3
3706            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3707 C     &      *2.0
3708            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3709      &              rlocshield
3710      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3711             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3712      &      +rlocshield
3713            enddo
3714           enddo
3715           do ilist=1,ishield_list(j)
3716            iresshield=shield_list(ilist,j)
3717            do k=1,3
3718            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3719 C     &     *2.0
3720            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3721      &              rlocshield
3722      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3723            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3724      &             +rlocshield
3725
3726            enddo
3727           enddo
3728
3729           do k=1,3
3730             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3731      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3732             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3733      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3734             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3735      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3736             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3737      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3738            enddo
3739            endif
3740 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3741 cd     &    ' eello_turn4_num',8*eello_turn4_num
3742 #ifdef NEWCORR
3743         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3744      &                  -(gs13+gsE13+gsEE1)*wturn4
3745      &  *fac_shield(i)*fac_shield(j)
3746         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3747      &                    -(gs23+gs21+gsEE2)*wturn4
3748      &  *fac_shield(i)*fac_shield(j)
3749
3750         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3751      &                    -(gs32+gsE31+gsEE3)*wturn4
3752      &  *fac_shield(i)*fac_shield(j)
3753
3754 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3755 c     &   gs2
3756 #endif
3757         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3758      &      'eturn4',i,j,-(s1+s2+s3)
3759 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3760 c     &    ' eello_turn4_num',8*eello_turn4_num
3761 C Derivatives in gamma(i)
3762         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3763         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3764         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3765         s1=scalar2(b1(1,i+2),auxvec(1))
3766         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3767         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3768         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3769      &  *fac_shield(i)*fac_shield(j)
3770 C Derivatives in gamma(i+1)
3771         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3772         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3773         s2=scalar2(b1(1,i+1),auxvec(1))
3774         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3775         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3776         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3777         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3778      &  *fac_shield(i)*fac_shield(j)
3779 C Derivatives in gamma(i+2)
3780         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3781         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3782         s1=scalar2(b1(1,i+2),auxvec(1))
3783         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3784         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3785         s2=scalar2(b1(1,i+1),auxvec(1))
3786         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3787         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3788         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3789         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3790      &  *fac_shield(i)*fac_shield(j)
3791         if (calc_grad) then
3792 C Cartesian derivatives
3793 C Derivatives of this turn contributions in DC(i+2)
3794         if (j.lt.nres-1) then
3795           do l=1,3
3796             a_temp(1,1)=agg(l,1)
3797             a_temp(1,2)=agg(l,2)
3798             a_temp(2,1)=agg(l,3)
3799             a_temp(2,2)=agg(l,4)
3800             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3801             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3802             s1=scalar2(b1(1,i+2),auxvec(1))
3803             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3804             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3805             s2=scalar2(b1(1,i+1),auxvec(1))
3806             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3807             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3808             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3809             ggg(l)=-(s1+s2+s3)
3810             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3811      &  *fac_shield(i)*fac_shield(j)
3812           enddo
3813         endif
3814 C Remaining derivatives of this turn contribution
3815         do l=1,3
3816           a_temp(1,1)=aggi(l,1)
3817           a_temp(1,2)=aggi(l,2)
3818           a_temp(2,1)=aggi(l,3)
3819           a_temp(2,2)=aggi(l,4)
3820           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3821           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3822           s1=scalar2(b1(1,i+2),auxvec(1))
3823           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3824           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3825           s2=scalar2(b1(1,i+1),auxvec(1))
3826           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3827           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3828           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3829           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3830      &  *fac_shield(i)*fac_shield(j)
3831           a_temp(1,1)=aggi1(l,1)
3832           a_temp(1,2)=aggi1(l,2)
3833           a_temp(2,1)=aggi1(l,3)
3834           a_temp(2,2)=aggi1(l,4)
3835           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3836           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3837           s1=scalar2(b1(1,i+2),auxvec(1))
3838           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3839           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3840           s2=scalar2(b1(1,i+1),auxvec(1))
3841           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3842           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3843           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3844           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3845      &  *fac_shield(i)*fac_shield(j)
3846           a_temp(1,1)=aggj(l,1)
3847           a_temp(1,2)=aggj(l,2)
3848           a_temp(2,1)=aggj(l,3)
3849           a_temp(2,2)=aggj(l,4)
3850           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3851           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3852           s1=scalar2(b1(1,i+2),auxvec(1))
3853           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3854           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3855           s2=scalar2(b1(1,i+1),auxvec(1))
3856           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3857           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3858           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3859           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3860      &  *fac_shield(i)*fac_shield(j)
3861           a_temp(1,1)=aggj1(l,1)
3862           a_temp(1,2)=aggj1(l,2)
3863           a_temp(2,1)=aggj1(l,3)
3864           a_temp(2,2)=aggj1(l,4)
3865           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3866           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3867           s1=scalar2(b1(1,i+2),auxvec(1))
3868           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3869           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3870           s2=scalar2(b1(1,i+1),auxvec(1))
3871           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3872           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3873           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3875           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3876      &  *fac_shield(i)*fac_shield(j)
3877         enddo
3878
3879         endif ! calc_grad
3880
3881       return
3882       end
3883 C-----------------------------------------------------------------------------
3884       subroutine vecpr(u,v,w)
3885       implicit real*8(a-h,o-z)
3886       dimension u(3),v(3),w(3)
3887       w(1)=u(2)*v(3)-u(3)*v(2)
3888       w(2)=-u(1)*v(3)+u(3)*v(1)
3889       w(3)=u(1)*v(2)-u(2)*v(1)
3890       return
3891       end
3892 C-----------------------------------------------------------------------------
3893       subroutine unormderiv(u,ugrad,unorm,ungrad)
3894 C This subroutine computes the derivatives of a normalized vector u, given
3895 C the derivatives computed without normalization conditions, ugrad. Returns
3896 C ungrad.
3897       implicit none
3898       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3899       double precision vec(3)
3900       double precision scalar
3901       integer i,j
3902 c      write (2,*) 'ugrad',ugrad
3903 c      write (2,*) 'u',u
3904       do i=1,3
3905         vec(i)=scalar(ugrad(1,i),u(1))
3906       enddo
3907 c      write (2,*) 'vec',vec
3908       do i=1,3
3909         do j=1,3
3910           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3911         enddo
3912       enddo
3913 c      write (2,*) 'ungrad',ungrad
3914       return
3915       end
3916 C-----------------------------------------------------------------------------
3917       subroutine escp(evdw2,evdw2_14)
3918 C
3919 C This subroutine calculates the excluded-volume interaction energy between
3920 C peptide-group centers and side chains and its gradient in virtual-bond and
3921 C side-chain vectors.
3922 C
3923       implicit real*8 (a-h,o-z)
3924       include 'DIMENSIONS'
3925       include 'COMMON.GEO'
3926       include 'COMMON.VAR'
3927       include 'COMMON.LOCAL'
3928       include 'COMMON.CHAIN'
3929       include 'COMMON.DERIV'
3930       include 'COMMON.INTERACT'
3931       include 'COMMON.FFIELD'
3932       include 'COMMON.IOUNITS'
3933       dimension ggg(3)
3934       evdw2=0.0D0
3935       evdw2_14=0.0d0
3936 cd    print '(a)','Enter ESCP'
3937 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3938 c     &  ' scal14',scal14
3939       do i=iatscp_s,iatscp_e
3940         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3941         iteli=itel(i)
3942 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3943 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3944         if (iteli.eq.0) goto 1225
3945         xi=0.5D0*(c(1,i)+c(1,i+1))
3946         yi=0.5D0*(c(2,i)+c(2,i+1))
3947         zi=0.5D0*(c(3,i)+c(3,i+1))
3948 C Returning the ith atom to box
3949           xi=mod(xi,boxxsize)
3950           if (xi.lt.0) xi=xi+boxxsize
3951           yi=mod(yi,boxysize)
3952           if (yi.lt.0) yi=yi+boxysize
3953           zi=mod(zi,boxzsize)
3954           if (zi.lt.0) zi=zi+boxzsize
3955         do iint=1,nscp_gr(i)
3956
3957         do j=iscpstart(i,iint),iscpend(i,iint)
3958           itypj=iabs(itype(j))
3959           if (itypj.eq.ntyp1) cycle
3960 C Uncomment following three lines for SC-p interactions
3961 c         xj=c(1,nres+j)-xi
3962 c         yj=c(2,nres+j)-yi
3963 c         zj=c(3,nres+j)-zi
3964 C Uncomment following three lines for Ca-p interactions
3965           xj=c(1,j)
3966           yj=c(2,j)
3967           zj=c(3,j)
3968 C returning the jth atom to box
3969           xj=mod(xj,boxxsize)
3970           if (xj.lt.0) xj=xj+boxxsize
3971           yj=mod(yj,boxysize)
3972           if (yj.lt.0) yj=yj+boxysize
3973           zj=mod(zj,boxzsize)
3974           if (zj.lt.0) zj=zj+boxzsize
3975       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3976       xj_safe=xj
3977       yj_safe=yj
3978       zj_safe=zj
3979       subchap=0
3980 C Finding the closest jth atom
3981       do xshift=-1,1
3982       do yshift=-1,1
3983       do zshift=-1,1
3984           xj=xj_safe+xshift*boxxsize
3985           yj=yj_safe+yshift*boxysize
3986           zj=zj_safe+zshift*boxzsize
3987           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3988           if(dist_temp.lt.dist_init) then
3989             dist_init=dist_temp
3990             xj_temp=xj
3991             yj_temp=yj
3992             zj_temp=zj
3993             subchap=1
3994           endif
3995        enddo
3996        enddo
3997        enddo
3998        if (subchap.eq.1) then
3999           xj=xj_temp-xi
4000           yj=yj_temp-yi
4001           zj=zj_temp-zi
4002        else
4003           xj=xj_safe-xi
4004           yj=yj_safe-yi
4005           zj=zj_safe-zi
4006        endif
4007           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4008 C sss is scaling function for smoothing the cutoff gradient otherwise
4009 C the gradient would not be continuouse
4010           sss=sscale(1.0d0/(dsqrt(rrij)))
4011           if (sss.le.0.0d0) cycle
4012           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4013           fac=rrij**expon2
4014           e1=fac*fac*aad(itypj,iteli)
4015           e2=fac*bad(itypj,iteli)
4016           if (iabs(j-i) .le. 2) then
4017             e1=scal14*e1
4018             e2=scal14*e2
4019             evdw2_14=evdw2_14+(e1+e2)*sss
4020           endif
4021           evdwij=e1+e2
4022 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4023 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4024 c     &       bad(itypj,iteli)
4025           evdw2=evdw2+evdwij*sss
4026           if (calc_grad) then
4027 C
4028 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4029 C
4030           fac=-(evdwij+e1)*rrij*sss
4031           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4032           ggg(1)=xj*fac
4033           ggg(2)=yj*fac
4034           ggg(3)=zj*fac
4035           if (j.lt.i) then
4036 cd          write (iout,*) 'j<i'
4037 C Uncomment following three lines for SC-p interactions
4038 c           do k=1,3
4039 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4040 c           enddo
4041           else
4042 cd          write (iout,*) 'j>i'
4043             do k=1,3
4044               ggg(k)=-ggg(k)
4045 C Uncomment following line for SC-p interactions
4046 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4047             enddo
4048           endif
4049           do k=1,3
4050             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4051           enddo
4052           kstart=min0(i+1,j)
4053           kend=max0(i-1,j-1)
4054 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4055 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4056           do k=kstart,kend
4057             do l=1,3
4058               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4059             enddo
4060           enddo
4061           endif ! calc_grad
4062         enddo
4063         enddo ! iint
4064  1225   continue
4065       enddo ! i
4066       do i=1,nct
4067         do j=1,3
4068           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4069           gradx_scp(j,i)=expon*gradx_scp(j,i)
4070         enddo
4071       enddo
4072 C******************************************************************************
4073 C
4074 C                              N O T E !!!
4075 C
4076 C To save time the factor EXPON has been extracted from ALL components
4077 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4078 C use!
4079 C
4080 C******************************************************************************
4081       return
4082       end
4083 C--------------------------------------------------------------------------
4084       subroutine edis(ehpb)
4085 C
4086 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4087 C
4088       implicit real*8 (a-h,o-z)
4089       include 'DIMENSIONS'
4090       include 'COMMON.SBRIDGE'
4091       include 'COMMON.CHAIN'
4092       include 'COMMON.DERIV'
4093       include 'COMMON.VAR'
4094       include 'COMMON.INTERACT'
4095       include 'COMMON.CONTROL'
4096       include 'COMMON.IOUNITS'
4097       dimension ggg(3),ggg_peak(3,1000)
4098       ehpb=0.0D0
4099       ggg=0.0d0
4100 c 8/21/18 AL: added explicit restraints on reference coords
4101 c      write (iout,*) "restr_on_coord",restr_on_coord
4102       if (restr_on_coord) then
4103
4104       do i=nnt,nct
4105         ecoor=0.0d0
4106         if (itype(i).eq.ntyp1) cycle
4107         do j=1,3
4108           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4109           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4110         enddo
4111         if (itype(i).ne.10) then
4112           do j=1,3
4113             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4114             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4115           enddo
4116         endif
4117         if (energy_dec) write (iout,*)
4118      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4119         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4120       enddo
4121
4122       endif
4123 C      write (iout,*) ,"link_end",link_end,constr_dist
4124 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4125 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4126 c     &  " constr_dist",constr_dist
4127       if (link_end.eq.0.and.link_end_peak.eq.0) return
4128       do i=link_start_peak,link_end_peak
4129         ehpb_peak=0.0d0
4130 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4131 c     &   ipeak(1,i),ipeak(2,i)
4132         do ip=ipeak(1,i),ipeak(2,i)
4133           ii=ihpb_peak(ip)
4134           jj=jhpb_peak(ip)
4135           dd=dist(ii,jj)
4136           iip=ip-ipeak(1,i)+1
4137 C iii and jjj point to the residues for which the distance is assigned.
4138 c          if (ii.gt.nres) then
4139 c            iii=ii-nres
4140 c            jjj=jj-nres
4141 c          else
4142 c            iii=ii
4143 c            jjj=jj
4144 c          endif
4145           if (ii.gt.nres) then
4146             iii=ii-nres
4147           else
4148             iii=ii
4149           endif
4150           if (jj.gt.nres) then
4151             jjj=jj-nres
4152           else
4153             jjj=jj
4154           endif
4155           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4156           aux=dexp(-scal_peak*aux)
4157           ehpb_peak=ehpb_peak+aux
4158           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4159      &      forcon_peak(ip))*aux/dd
4160           do j=1,3
4161             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4162           enddo
4163           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4164      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4165      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4166         enddo
4167 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4168         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4169         do ip=ipeak(1,i),ipeak(2,i)
4170           iip=ip-ipeak(1,i)+1
4171           do j=1,3
4172             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4173           enddo
4174           ii=ihpb_peak(ip)
4175           jj=jhpb_peak(ip)
4176 C iii and jjj point to the residues for which the distance is assigned.
4177 c          if (ii.gt.nres) then
4178 c            iii=ii-nres
4179 c            jjj=jj-nres
4180 c          else
4181 c            iii=ii
4182 c            jjj=jj
4183 c          endif
4184           if (ii.gt.nres) then
4185             iii=ii-nres
4186           else
4187             iii=ii
4188           endif
4189           if (jj.gt.nres) then
4190             jjj=jj-nres
4191           else
4192             jjj=jj
4193           endif
4194           if (iii.lt.ii) then
4195             do j=1,3
4196               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4197             enddo
4198           endif
4199           if (jjj.lt.jj) then
4200             do j=1,3
4201               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4202             enddo
4203           endif
4204           do k=1,3
4205             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4206             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4207           enddo
4208         enddo
4209       enddo
4210       do i=link_start,link_end
4211 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4212 C CA-CA distance used in regularization of structure.
4213         ii=ihpb(i)
4214         jj=jhpb(i)
4215 C iii and jjj point to the residues for which the distance is assigned.
4216 c        if (ii.gt.nres) then
4217 c          iii=ii-nres
4218 c          jjj=jj-nres
4219 c        else
4220 c          iii=ii
4221 c          jjj=jj
4222 c        endif
4223         if (ii.gt.nres) then
4224           iii=ii-nres
4225         else
4226           iii=ii
4227         endif
4228         if (jj.gt.nres) then
4229           jjj=jj-nres
4230         else
4231           jjj=jj
4232         endif
4233 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4234 c     &    dhpb(i),dhpb1(i),forcon(i)
4235 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4236 C    distance and angle dependent SS bond potential.
4237 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4238 C     & iabs(itype(jjj)).eq.1) then
4239 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4240 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4241         if (.not.dyn_ss .and. i.le.nss) then
4242 C 15/02/13 CC dynamic SSbond - additional check
4243           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4244      &        iabs(itype(jjj)).eq.1) then
4245            call ssbond_ene(iii,jjj,eij)
4246            ehpb=ehpb+2*eij
4247          endif
4248 cd          write (iout,*) "eij",eij
4249 cd   &   ' waga=',waga,' fac=',fac
4250 !        else if (ii.gt.nres .and. jj.gt.nres) then
4251         else
4252 C Calculate the distance between the two points and its difference from the
4253 C target distance.
4254           dd=dist(ii,jj)
4255           if (irestr_type(i).eq.11) then
4256             ehpb=ehpb+fordepth(i)!**4.0d0
4257      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4258             fac=fordepth(i)!**4.0d0
4259      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4260             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4261      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4262      &        ehpb,irestr_type(i)
4263           else if (irestr_type(i).eq.10) then
4264 c AL 6//19/2018 cross-link restraints
4265             xdis = 0.5d0*(dd/forcon(i))**2
4266             expdis = dexp(-xdis)
4267 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4268             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4269 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4270 c     &          " wboltzd",wboltzd
4271             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4272 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4273             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4274      &           *expdis/(aux*forcon(i)**2)
4275             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4276      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4277      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4278           else if (irestr_type(i).eq.2) then
4279 c Quartic restraints
4280             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4281             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4282      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4283      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4284             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4285           else
4286 c Quadratic restraints
4287             rdis=dd-dhpb(i)
4288 C Get the force constant corresponding to this distance.
4289             waga=forcon(i)
4290 C Calculate the contribution to energy.
4291             ehpb=ehpb+0.5d0*waga*rdis*rdis
4292             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4293      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4294      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4295 C
4296 C Evaluate gradient.
4297 C
4298             fac=waga*rdis/dd
4299           endif
4300 c Calculate Cartesian gradient
4301           do j=1,3
4302             ggg(j)=fac*(c(j,jj)-c(j,ii))
4303           enddo
4304 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4305 C If this is a SC-SC distance, we need to calculate the contributions to the
4306 C Cartesian gradient in the SC vectors (ghpbx).
4307           if (iii.lt.ii) then
4308             do j=1,3
4309               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4310             enddo
4311           endif
4312           if (jjj.lt.jj) then
4313             do j=1,3
4314               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4315             enddo
4316           endif
4317           do k=1,3
4318             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4319             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4320           enddo
4321         endif
4322       enddo
4323       return
4324       end
4325 C--------------------------------------------------------------------------
4326       subroutine ssbond_ene(i,j,eij)
4327 C
4328 C Calculate the distance and angle dependent SS-bond potential energy
4329 C using a free-energy function derived based on RHF/6-31G** ab initio
4330 C calculations of diethyl disulfide.
4331 C
4332 C A. Liwo and U. Kozlowska, 11/24/03
4333 C
4334       implicit real*8 (a-h,o-z)
4335       include 'DIMENSIONS'
4336       include 'COMMON.SBRIDGE'
4337       include 'COMMON.CHAIN'
4338       include 'COMMON.DERIV'
4339       include 'COMMON.LOCAL'
4340       include 'COMMON.INTERACT'
4341       include 'COMMON.VAR'
4342       include 'COMMON.IOUNITS'
4343       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4344       itypi=iabs(itype(i))
4345       xi=c(1,nres+i)
4346       yi=c(2,nres+i)
4347       zi=c(3,nres+i)
4348       dxi=dc_norm(1,nres+i)
4349       dyi=dc_norm(2,nres+i)
4350       dzi=dc_norm(3,nres+i)
4351       dsci_inv=dsc_inv(itypi)
4352       itypj=iabs(itype(j))
4353       dscj_inv=dsc_inv(itypj)
4354       xj=c(1,nres+j)-xi
4355       yj=c(2,nres+j)-yi
4356       zj=c(3,nres+j)-zi
4357       dxj=dc_norm(1,nres+j)
4358       dyj=dc_norm(2,nres+j)
4359       dzj=dc_norm(3,nres+j)
4360       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4361       rij=dsqrt(rrij)
4362       erij(1)=xj*rij
4363       erij(2)=yj*rij
4364       erij(3)=zj*rij
4365       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4366       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4367       om12=dxi*dxj+dyi*dyj+dzi*dzj
4368       do k=1,3
4369         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4370         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4371       enddo
4372       rij=1.0d0/rij
4373       deltad=rij-d0cm
4374       deltat1=1.0d0-om1
4375       deltat2=1.0d0+om2
4376       deltat12=om2-om1+2.0d0
4377       cosphi=om12-om1*om2
4378       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4379      &  +akct*deltad*deltat12
4380      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4381 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4382 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4383 c     &  " deltat12",deltat12," eij",eij
4384       ed=2*akcm*deltad+akct*deltat12
4385       pom1=akct*deltad
4386       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4387       eom1=-2*akth*deltat1-pom1-om2*pom2
4388       eom2= 2*akth*deltat2+pom1-om1*pom2
4389       eom12=pom2
4390       do k=1,3
4391         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4392       enddo
4393       do k=1,3
4394         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4395      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4396         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4397      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4398       enddo
4399 C
4400 C Calculate the components of the gradient in DC and X
4401 C
4402       do k=i,j-1
4403         do l=1,3
4404           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4405         enddo
4406       enddo
4407       return
4408       end
4409 C--------------------------------------------------------------------------
4410       subroutine ebond(estr)
4411 c
4412 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4413 c
4414       implicit real*8 (a-h,o-z)
4415       include 'DIMENSIONS'
4416       include 'COMMON.LOCAL'
4417       include 'COMMON.GEO'
4418       include 'COMMON.INTERACT'
4419       include 'COMMON.DERIV'
4420       include 'COMMON.VAR'
4421       include 'COMMON.CHAIN'
4422       include 'COMMON.IOUNITS'
4423       include 'COMMON.NAMES'
4424       include 'COMMON.FFIELD'
4425       include 'COMMON.CONTROL'
4426       double precision u(3),ud(3)
4427       estr=0.0d0
4428       estr1=0.0d0
4429 c      write (iout,*) "distchainmax",distchainmax
4430       do i=nnt+1,nct
4431         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4432 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4433 C          do j=1,3
4434 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4435 C     &      *dc(j,i-1)/vbld(i)
4436 C          enddo
4437 C          if (energy_dec) write(iout,*)
4438 C     &       "estr1",i,vbld(i),distchainmax,
4439 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4440 C        else
4441          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4442         diff = vbld(i)-vbldpDUM
4443 C         write(iout,*) i,diff
4444          else
4445           diff = vbld(i)-vbldp0
4446 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4447          endif
4448           estr=estr+diff*diff
4449           do j=1,3
4450             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4451           enddo
4452 C        endif
4453 C        write (iout,'(a7,i5,4f7.3)')
4454 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4455       enddo
4456       estr=0.5d0*AKP*estr+estr1
4457 c
4458 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4459 c
4460       do i=nnt,nct
4461         iti=iabs(itype(i))
4462         if (iti.ne.10 .and. iti.ne.ntyp1) then
4463           nbi=nbondterm(iti)
4464           if (nbi.eq.1) then
4465             diff=vbld(i+nres)-vbldsc0(1,iti)
4466 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4467 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4468             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4469             do j=1,3
4470               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4471             enddo
4472           else
4473             do j=1,nbi
4474               diff=vbld(i+nres)-vbldsc0(j,iti)
4475               ud(j)=aksc(j,iti)*diff
4476               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4477             enddo
4478             uprod=u(1)
4479             do j=2,nbi
4480               uprod=uprod*u(j)
4481             enddo
4482             usum=0.0d0
4483             usumsqder=0.0d0
4484             do j=1,nbi
4485               uprod1=1.0d0
4486               uprod2=1.0d0
4487               do k=1,nbi
4488                 if (k.ne.j) then
4489                   uprod1=uprod1*u(k)
4490                   uprod2=uprod2*u(k)*u(k)
4491                 endif
4492               enddo
4493               usum=usum+uprod1
4494               usumsqder=usumsqder+ud(j)*uprod2
4495             enddo
4496 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4497 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4498             estr=estr+uprod/usum
4499             do j=1,3
4500              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4501             enddo
4502           endif
4503         endif
4504       enddo
4505       return
4506       end
4507 #ifdef CRYST_THETA
4508 C--------------------------------------------------------------------------
4509       subroutine ebend(etheta,ethetacnstr)
4510 C
4511 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4512 C angles gamma and its derivatives in consecutive thetas and gammas.
4513 C
4514       implicit real*8 (a-h,o-z)
4515       include 'DIMENSIONS'
4516       include 'COMMON.LOCAL'
4517       include 'COMMON.GEO'
4518       include 'COMMON.INTERACT'
4519       include 'COMMON.DERIV'
4520       include 'COMMON.VAR'
4521       include 'COMMON.CHAIN'
4522       include 'COMMON.IOUNITS'
4523       include 'COMMON.NAMES'
4524       include 'COMMON.FFIELD'
4525       include 'COMMON.TORCNSTR'
4526       common /calcthet/ term1,term2,termm,diffak,ratak,
4527      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4528      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4529       double precision y(2),z(2)
4530       delta=0.02d0*pi
4531 c      time11=dexp(-2*time)
4532 c      time12=1.0d0
4533       etheta=0.0D0
4534 c      write (iout,*) "nres",nres
4535 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4536 c      write (iout,*) ithet_start,ithet_end
4537       do i=ithet_start,ithet_end
4538 C        if (itype(i-1).eq.ntyp1) cycle
4539         if (i.le.2) cycle
4540         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4541      &  .or.itype(i).eq.ntyp1) cycle
4542 C Zero the energy function and its derivative at 0 or pi.
4543         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4544         it=itype(i-1)
4545         ichir1=isign(1,itype(i-2))
4546         ichir2=isign(1,itype(i))
4547          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4548          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4549          if (itype(i-1).eq.10) then
4550           itype1=isign(10,itype(i-2))
4551           ichir11=isign(1,itype(i-2))
4552           ichir12=isign(1,itype(i-2))
4553           itype2=isign(10,itype(i))
4554           ichir21=isign(1,itype(i))
4555           ichir22=isign(1,itype(i))
4556          endif
4557          if (i.eq.3) then
4558           y(1)=0.0D0
4559           y(2)=0.0D0
4560           else
4561
4562         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4563 #ifdef OSF
4564           phii=phi(i)
4565 c          icrc=0
4566 c          call proc_proc(phii,icrc)
4567           if (icrc.eq.1) phii=150.0
4568 #else
4569           phii=phi(i)
4570 #endif
4571           y(1)=dcos(phii)
4572           y(2)=dsin(phii)
4573         else
4574           y(1)=0.0D0
4575           y(2)=0.0D0
4576         endif
4577         endif
4578         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4579 #ifdef OSF
4580           phii1=phi(i+1)
4581 c          icrc=0
4582 c          call proc_proc(phii1,icrc)
4583           if (icrc.eq.1) phii1=150.0
4584           phii1=pinorm(phii1)
4585           z(1)=cos(phii1)
4586 #else
4587           phii1=phi(i+1)
4588           z(1)=dcos(phii1)
4589 #endif
4590           z(2)=dsin(phii1)
4591         else
4592           z(1)=0.0D0
4593           z(2)=0.0D0
4594         endif
4595 C Calculate the "mean" value of theta from the part of the distribution
4596 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4597 C In following comments this theta will be referred to as t_c.
4598         thet_pred_mean=0.0d0
4599         do k=1,2
4600             athetk=athet(k,it,ichir1,ichir2)
4601             bthetk=bthet(k,it,ichir1,ichir2)
4602           if (it.eq.10) then
4603              athetk=athet(k,itype1,ichir11,ichir12)
4604              bthetk=bthet(k,itype2,ichir21,ichir22)
4605           endif
4606           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4607         enddo
4608 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4609         dthett=thet_pred_mean*ssd
4610         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4611 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4612 C Derivatives of the "mean" values in gamma1 and gamma2.
4613         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4614      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4615          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4616      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4617          if (it.eq.10) then
4618       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4619      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4620         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4621      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4622          endif
4623         if (theta(i).gt.pi-delta) then
4624           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4625      &         E_tc0)
4626           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4627           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4628           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4629      &        E_theta)
4630           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4631      &        E_tc)
4632         else if (theta(i).lt.delta) then
4633           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4634           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4635           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4636      &        E_theta)
4637           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4638           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4639      &        E_tc)
4640         else
4641           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4642      &        E_theta,E_tc)
4643         endif
4644         etheta=etheta+ethetai
4645 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4646 c     &      'ebend',i,ethetai,theta(i),itype(i)
4647 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4648 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4649         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4650         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4651         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4652 c 1215   continue
4653       enddo
4654       ethetacnstr=0.0d0
4655 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4656       do i=1,ntheta_constr
4657         itheta=itheta_constr(i)
4658         thetiii=theta(itheta)
4659         difi=pinorm(thetiii-theta_constr0(i))
4660         if (difi.gt.theta_drange(i)) then
4661           difi=difi-theta_drange(i)
4662           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4663           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4664      &    +for_thet_constr(i)*difi**3
4665         else if (difi.lt.-drange(i)) then
4666           difi=difi+drange(i)
4667           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4668           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4669      &    +for_thet_constr(i)*difi**3
4670         else
4671           difi=0.0
4672         endif
4673 C       if (energy_dec) then
4674 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4675 C     &    i,itheta,rad2deg*thetiii,
4676 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4677 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4678 C     &    gloc(itheta+nphi-2,icg)
4679 C        endif
4680       enddo
4681 C Ufff.... We've done all this!!!
4682       return
4683       end
4684 C---------------------------------------------------------------------------
4685       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4686      &     E_tc)
4687       implicit real*8 (a-h,o-z)
4688       include 'DIMENSIONS'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.IOUNITS'
4691       common /calcthet/ term1,term2,termm,diffak,ratak,
4692      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4693      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4694 C Calculate the contributions to both Gaussian lobes.
4695 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4696 C The "polynomial part" of the "standard deviation" of this part of
4697 C the distribution.
4698         sig=polthet(3,it)
4699         do j=2,0,-1
4700           sig=sig*thet_pred_mean+polthet(j,it)
4701         enddo
4702 C Derivative of the "interior part" of the "standard deviation of the"
4703 C gamma-dependent Gaussian lobe in t_c.
4704         sigtc=3*polthet(3,it)
4705         do j=2,1,-1
4706           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4707         enddo
4708         sigtc=sig*sigtc
4709 C Set the parameters of both Gaussian lobes of the distribution.
4710 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4711         fac=sig*sig+sigc0(it)
4712         sigcsq=fac+fac
4713         sigc=1.0D0/sigcsq
4714 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4715         sigsqtc=-4.0D0*sigcsq*sigtc
4716 c       print *,i,sig,sigtc,sigsqtc
4717 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4718         sigtc=-sigtc/(fac*fac)
4719 C Following variable is sigma(t_c)**(-2)
4720         sigcsq=sigcsq*sigcsq
4721         sig0i=sig0(it)
4722         sig0inv=1.0D0/sig0i**2
4723         delthec=thetai-thet_pred_mean
4724         delthe0=thetai-theta0i
4725         term1=-0.5D0*sigcsq*delthec*delthec
4726         term2=-0.5D0*sig0inv*delthe0*delthe0
4727 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4728 C NaNs in taking the logarithm. We extract the largest exponent which is added
4729 C to the energy (this being the log of the distribution) at the end of energy
4730 C term evaluation for this virtual-bond angle.
4731         if (term1.gt.term2) then
4732           termm=term1
4733           term2=dexp(term2-termm)
4734           term1=1.0d0
4735         else
4736           termm=term2
4737           term1=dexp(term1-termm)
4738           term2=1.0d0
4739         endif
4740 C The ratio between the gamma-independent and gamma-dependent lobes of
4741 C the distribution is a Gaussian function of thet_pred_mean too.
4742         diffak=gthet(2,it)-thet_pred_mean
4743         ratak=diffak/gthet(3,it)**2
4744         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4745 C Let's differentiate it in thet_pred_mean NOW.
4746         aktc=ak*ratak
4747 C Now put together the distribution terms to make complete distribution.
4748         termexp=term1+ak*term2
4749         termpre=sigc+ak*sig0i
4750 C Contribution of the bending energy from this theta is just the -log of
4751 C the sum of the contributions from the two lobes and the pre-exponential
4752 C factor. Simple enough, isn't it?
4753         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4754 C NOW the derivatives!!!
4755 C 6/6/97 Take into account the deformation.
4756         E_theta=(delthec*sigcsq*term1
4757      &       +ak*delthe0*sig0inv*term2)/termexp
4758         E_tc=((sigtc+aktc*sig0i)/termpre
4759      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4760      &       aktc*term2)/termexp)
4761       return
4762       end
4763 c-----------------------------------------------------------------------------
4764       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.LOCAL'
4768       include 'COMMON.IOUNITS'
4769       common /calcthet/ term1,term2,termm,diffak,ratak,
4770      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4771      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4772       delthec=thetai-thet_pred_mean
4773       delthe0=thetai-theta0i
4774 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4775       t3 = thetai-thet_pred_mean
4776       t6 = t3**2
4777       t9 = term1
4778       t12 = t3*sigcsq
4779       t14 = t12+t6*sigsqtc
4780       t16 = 1.0d0
4781       t21 = thetai-theta0i
4782       t23 = t21**2
4783       t26 = term2
4784       t27 = t21*t26
4785       t32 = termexp
4786       t40 = t32**2
4787       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4788      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4789      & *(-t12*t9-ak*sig0inv*t27)
4790       return
4791       end
4792 #else
4793 C--------------------------------------------------------------------------
4794       subroutine ebend(etheta)
4795 C
4796 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4797 C angles gamma and its derivatives in consecutive thetas and gammas.
4798 C ab initio-derived potentials from
4799 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4800 C
4801       implicit real*8 (a-h,o-z)
4802       include 'DIMENSIONS'
4803       include 'COMMON.LOCAL'
4804       include 'COMMON.GEO'
4805       include 'COMMON.INTERACT'
4806       include 'COMMON.DERIV'
4807       include 'COMMON.VAR'
4808       include 'COMMON.CHAIN'
4809       include 'COMMON.IOUNITS'
4810       include 'COMMON.NAMES'
4811       include 'COMMON.FFIELD'
4812       include 'COMMON.CONTROL'
4813       include 'COMMON.TORCNSTR'
4814       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4815      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4816      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4817      & sinph1ph2(maxdouble,maxdouble)
4818       logical lprn /.false./, lprn1 /.false./
4819       etheta=0.0D0
4820 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4821       do i=ithet_start,ithet_end
4822 C         if (i.eq.2) cycle
4823 C        if (itype(i-1).eq.ntyp1) cycle
4824         if (i.le.2) cycle
4825         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4826      &  .or.itype(i).eq.ntyp1) cycle
4827         if (iabs(itype(i+1)).eq.20) iblock=2
4828         if (iabs(itype(i+1)).ne.20) iblock=1
4829         dethetai=0.0d0
4830         dephii=0.0d0
4831         dephii1=0.0d0
4832         theti2=0.5d0*theta(i)
4833         ityp2=ithetyp((itype(i-1)))
4834         do k=1,nntheterm
4835           coskt(k)=dcos(k*theti2)
4836           sinkt(k)=dsin(k*theti2)
4837         enddo
4838         if (i.eq.3) then
4839           phii=0.0d0
4840           ityp1=nthetyp+1
4841           do k=1,nsingle
4842             cosph1(k)=0.0d0
4843             sinph1(k)=0.0d0
4844           enddo
4845         else
4846         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4847 #ifdef OSF
4848           phii=phi(i)
4849           if (phii.ne.phii) phii=150.0
4850 #else
4851           phii=phi(i)
4852 #endif
4853           ityp1=ithetyp((itype(i-2)))
4854           do k=1,nsingle
4855             cosph1(k)=dcos(k*phii)
4856             sinph1(k)=dsin(k*phii)
4857           enddo
4858         else
4859           phii=0.0d0
4860 c          ityp1=nthetyp+1
4861           do k=1,nsingle
4862             ityp1=ithetyp((itype(i-2)))
4863             cosph1(k)=0.0d0
4864             sinph1(k)=0.0d0
4865           enddo
4866         endif
4867         endif
4868         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4869 #ifdef OSF
4870           phii1=phi(i+1)
4871           if (phii1.ne.phii1) phii1=150.0
4872           phii1=pinorm(phii1)
4873 #else
4874           phii1=phi(i+1)
4875 #endif
4876           ityp3=ithetyp((itype(i)))
4877           do k=1,nsingle
4878             cosph2(k)=dcos(k*phii1)
4879             sinph2(k)=dsin(k*phii1)
4880           enddo
4881         else
4882           phii1=0.0d0
4883 c          ityp3=nthetyp+1
4884           ityp3=ithetyp((itype(i)))
4885           do k=1,nsingle
4886             cosph2(k)=0.0d0
4887             sinph2(k)=0.0d0
4888           enddo
4889         endif
4890 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4891 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4892 c        call flush(iout)
4893         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4894         do k=1,ndouble
4895           do l=1,k-1
4896             ccl=cosph1(l)*cosph2(k-l)
4897             ssl=sinph1(l)*sinph2(k-l)
4898             scl=sinph1(l)*cosph2(k-l)
4899             csl=cosph1(l)*sinph2(k-l)
4900             cosph1ph2(l,k)=ccl-ssl
4901             cosph1ph2(k,l)=ccl+ssl
4902             sinph1ph2(l,k)=scl+csl
4903             sinph1ph2(k,l)=scl-csl
4904           enddo
4905         enddo
4906         if (lprn) then
4907         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4908      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4909         write (iout,*) "coskt and sinkt"
4910         do k=1,nntheterm
4911           write (iout,*) k,coskt(k),sinkt(k)
4912         enddo
4913         endif
4914         do k=1,ntheterm
4915           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4916           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4917      &      *coskt(k)
4918           if (lprn)
4919      &    write (iout,*) "k",k,"
4920      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4921      &     " ethetai",ethetai
4922         enddo
4923         if (lprn) then
4924         write (iout,*) "cosph and sinph"
4925         do k=1,nsingle
4926           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4927         enddo
4928         write (iout,*) "cosph1ph2 and sinph2ph2"
4929         do k=2,ndouble
4930           do l=1,k-1
4931             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4932      &         sinph1ph2(l,k),sinph1ph2(k,l)
4933           enddo
4934         enddo
4935         write(iout,*) "ethetai",ethetai
4936         endif
4937         do m=1,ntheterm2
4938           do k=1,nsingle
4939             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4940      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4941      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4942      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4943             ethetai=ethetai+sinkt(m)*aux
4944             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4945             dephii=dephii+k*sinkt(m)*(
4946      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4947      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4948             dephii1=dephii1+k*sinkt(m)*(
4949      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4950      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4951             if (lprn)
4952      &      write (iout,*) "m",m," k",k," bbthet",
4953      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4954      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4955      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4956      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4957           enddo
4958         enddo
4959         if (lprn)
4960      &  write(iout,*) "ethetai",ethetai
4961         do m=1,ntheterm3
4962           do k=2,ndouble
4963             do l=1,k-1
4964               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4965      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4966      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4967      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4968               ethetai=ethetai+sinkt(m)*aux
4969               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4970               dephii=dephii+l*sinkt(m)*(
4971      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4972      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4973      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4974      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4975               dephii1=dephii1+(k-l)*sinkt(m)*(
4976      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4977      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4978      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4979      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4980               if (lprn) then
4981               write (iout,*) "m",m," k",k," l",l," ffthet",
4982      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4983      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4984      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4985      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4986      &            " ethetai",ethetai
4987               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4988      &            cosph1ph2(k,l)*sinkt(m),
4989      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4990               endif
4991             enddo
4992           enddo
4993         enddo
4994 10      continue
4995         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4996      &   i,theta(i)*rad2deg,phii*rad2deg,
4997      &   phii1*rad2deg,ethetai
4998         etheta=etheta+ethetai
4999         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5000         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5001 c        gloc(nphi+i-2,icg)=wang*dethetai
5002         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5003       enddo
5004       return
5005       end
5006 #endif
5007 #ifdef CRYST_SC
5008 c-----------------------------------------------------------------------------
5009       subroutine esc(escloc)
5010 C Calculate the local energy of a side chain and its derivatives in the
5011 C corresponding virtual-bond valence angles THETA and the spherical angles
5012 C ALPHA and OMEGA.
5013       implicit real*8 (a-h,o-z)
5014       include 'DIMENSIONS'
5015       include 'COMMON.GEO'
5016       include 'COMMON.LOCAL'
5017       include 'COMMON.VAR'
5018       include 'COMMON.INTERACT'
5019       include 'COMMON.DERIV'
5020       include 'COMMON.CHAIN'
5021       include 'COMMON.IOUNITS'
5022       include 'COMMON.NAMES'
5023       include 'COMMON.FFIELD'
5024       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5025      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5026       common /sccalc/ time11,time12,time112,theti,it,nlobit
5027       delta=0.02d0*pi
5028       escloc=0.0D0
5029 C      write (iout,*) 'ESC'
5030       do i=loc_start,loc_end
5031         it=itype(i)
5032         if (it.eq.ntyp1) cycle
5033         if (it.eq.10) goto 1
5034         nlobit=nlob(iabs(it))
5035 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5036 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5037         theti=theta(i+1)-pipol
5038         x(1)=dtan(theti)
5039         x(2)=alph(i)
5040         x(3)=omeg(i)
5041 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5042
5043         if (x(2).gt.pi-delta) then
5044           xtemp(1)=x(1)
5045           xtemp(2)=pi-delta
5046           xtemp(3)=x(3)
5047           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5048           xtemp(2)=pi
5049           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5050           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5051      &        escloci,dersc(2))
5052           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5053      &        ddersc0(1),dersc(1))
5054           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5055      &        ddersc0(3),dersc(3))
5056           xtemp(2)=pi-delta
5057           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5058           xtemp(2)=pi
5059           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5060           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5061      &            dersc0(2),esclocbi,dersc02)
5062           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5063      &            dersc12,dersc01)
5064           call splinthet(x(2),0.5d0*delta,ss,ssd)
5065           dersc0(1)=dersc01
5066           dersc0(2)=dersc02
5067           dersc0(3)=0.0d0
5068           do k=1,3
5069             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5070           enddo
5071           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5072           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5073      &             esclocbi,ss,ssd
5074           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5075 c         escloci=esclocbi
5076 c         write (iout,*) escloci
5077         else if (x(2).lt.delta) then
5078           xtemp(1)=x(1)
5079           xtemp(2)=delta
5080           xtemp(3)=x(3)
5081           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5082           xtemp(2)=0.0d0
5083           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5084           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5085      &        escloci,dersc(2))
5086           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5087      &        ddersc0(1),dersc(1))
5088           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5089      &        ddersc0(3),dersc(3))
5090           xtemp(2)=delta
5091           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5092           xtemp(2)=0.0d0
5093           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5094           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5095      &            dersc0(2),esclocbi,dersc02)
5096           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5097      &            dersc12,dersc01)
5098           dersc0(1)=dersc01
5099           dersc0(2)=dersc02
5100           dersc0(3)=0.0d0
5101           call splinthet(x(2),0.5d0*delta,ss,ssd)
5102           do k=1,3
5103             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5104           enddo
5105           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5106 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5107 c     &             esclocbi,ss,ssd
5108           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5109 C         write (iout,*) 'i=',i, escloci
5110         else
5111           call enesc(x,escloci,dersc,ddummy,.false.)
5112         endif
5113
5114         escloc=escloc+escloci
5115 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5116             write (iout,'(a6,i5,0pf7.3)')
5117      &     'escloc',i,escloci
5118
5119         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5120      &   wscloc*dersc(1)
5121         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5122         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5123     1   continue
5124       enddo
5125       return
5126       end
5127 C---------------------------------------------------------------------------
5128       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5129       implicit real*8 (a-h,o-z)
5130       include 'DIMENSIONS'
5131       include 'COMMON.GEO'
5132       include 'COMMON.LOCAL'
5133       include 'COMMON.IOUNITS'
5134       common /sccalc/ time11,time12,time112,theti,it,nlobit
5135       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5136       double precision contr(maxlob,-1:1)
5137       logical mixed
5138 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5139         escloc_i=0.0D0
5140         do j=1,3
5141           dersc(j)=0.0D0
5142           if (mixed) ddersc(j)=0.0d0
5143         enddo
5144         x3=x(3)
5145
5146 C Because of periodicity of the dependence of the SC energy in omega we have
5147 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5148 C To avoid underflows, first compute & store the exponents.
5149
5150         do iii=-1,1
5151
5152           x(3)=x3+iii*dwapi
5153
5154           do j=1,nlobit
5155             do k=1,3
5156               z(k)=x(k)-censc(k,j,it)
5157             enddo
5158             do k=1,3
5159               Axk=0.0D0
5160               do l=1,3
5161                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5162               enddo
5163               Ax(k,j,iii)=Axk
5164             enddo
5165             expfac=0.0D0
5166             do k=1,3
5167               expfac=expfac+Ax(k,j,iii)*z(k)
5168             enddo
5169             contr(j,iii)=expfac
5170           enddo ! j
5171
5172         enddo ! iii
5173
5174         x(3)=x3
5175 C As in the case of ebend, we want to avoid underflows in exponentiation and
5176 C subsequent NaNs and INFs in energy calculation.
5177 C Find the largest exponent
5178         emin=contr(1,-1)
5179         do iii=-1,1
5180           do j=1,nlobit
5181             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5182           enddo
5183         enddo
5184         emin=0.5D0*emin
5185 cd      print *,'it=',it,' emin=',emin
5186
5187 C Compute the contribution to SC energy and derivatives
5188         do iii=-1,1
5189
5190           do j=1,nlobit
5191             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5192 cd          print *,'j=',j,' expfac=',expfac
5193             escloc_i=escloc_i+expfac
5194             do k=1,3
5195               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5196             enddo
5197             if (mixed) then
5198               do k=1,3,2
5199                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5200      &            +gaussc(k,2,j,it))*expfac
5201               enddo
5202             endif
5203           enddo
5204
5205         enddo ! iii
5206
5207         dersc(1)=dersc(1)/cos(theti)**2
5208         ddersc(1)=ddersc(1)/cos(theti)**2
5209         ddersc(3)=ddersc(3)
5210
5211         escloci=-(dlog(escloc_i)-emin)
5212         do j=1,3
5213           dersc(j)=dersc(j)/escloc_i
5214         enddo
5215         if (mixed) then
5216           do j=1,3,2
5217             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5218           enddo
5219         endif
5220       return
5221       end
5222 C------------------------------------------------------------------------------
5223       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5224       implicit real*8 (a-h,o-z)
5225       include 'DIMENSIONS'
5226       include 'COMMON.GEO'
5227       include 'COMMON.LOCAL'
5228       include 'COMMON.IOUNITS'
5229       common /sccalc/ time11,time12,time112,theti,it,nlobit
5230       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5231       double precision contr(maxlob)
5232       logical mixed
5233
5234       escloc_i=0.0D0
5235
5236       do j=1,3
5237         dersc(j)=0.0D0
5238       enddo
5239
5240       do j=1,nlobit
5241         do k=1,2
5242           z(k)=x(k)-censc(k,j,it)
5243         enddo
5244         z(3)=dwapi
5245         do k=1,3
5246           Axk=0.0D0
5247           do l=1,3
5248             Axk=Axk+gaussc(l,k,j,it)*z(l)
5249           enddo
5250           Ax(k,j)=Axk
5251         enddo
5252         expfac=0.0D0
5253         do k=1,3
5254           expfac=expfac+Ax(k,j)*z(k)
5255         enddo
5256         contr(j)=expfac
5257       enddo ! j
5258
5259 C As in the case of ebend, we want to avoid underflows in exponentiation and
5260 C subsequent NaNs and INFs in energy calculation.
5261 C Find the largest exponent
5262       emin=contr(1)
5263       do j=1,nlobit
5264         if (emin.gt.contr(j)) emin=contr(j)
5265       enddo
5266       emin=0.5D0*emin
5267
5268 C Compute the contribution to SC energy and derivatives
5269
5270       dersc12=0.0d0
5271       do j=1,nlobit
5272         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5273         escloc_i=escloc_i+expfac
5274         do k=1,2
5275           dersc(k)=dersc(k)+Ax(k,j)*expfac
5276         enddo
5277         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5278      &            +gaussc(1,2,j,it))*expfac
5279         dersc(3)=0.0d0
5280       enddo
5281
5282       dersc(1)=dersc(1)/cos(theti)**2
5283       dersc12=dersc12/cos(theti)**2
5284       escloci=-(dlog(escloc_i)-emin)
5285       do j=1,2
5286         dersc(j)=dersc(j)/escloc_i
5287       enddo
5288       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5289       return
5290       end
5291 #else
5292 c----------------------------------------------------------------------------------
5293       subroutine esc(escloc)
5294 C Calculate the local energy of a side chain and its derivatives in the
5295 C corresponding virtual-bond valence angles THETA and the spherical angles
5296 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5297 C added by Urszula Kozlowska. 07/11/2007
5298 C
5299       implicit real*8 (a-h,o-z)
5300       include 'DIMENSIONS'
5301       include 'COMMON.GEO'
5302       include 'COMMON.LOCAL'
5303       include 'COMMON.VAR'
5304       include 'COMMON.SCROT'
5305       include 'COMMON.INTERACT'
5306       include 'COMMON.DERIV'
5307       include 'COMMON.CHAIN'
5308       include 'COMMON.IOUNITS'
5309       include 'COMMON.NAMES'
5310       include 'COMMON.FFIELD'
5311       include 'COMMON.CONTROL'
5312       include 'COMMON.VECTORS'
5313       double precision x_prime(3),y_prime(3),z_prime(3)
5314      &    , sumene,dsc_i,dp2_i,x(65),
5315      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5316      &    de_dxx,de_dyy,de_dzz,de_dt
5317       double precision s1_t,s1_6_t,s2_t,s2_6_t
5318       double precision
5319      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5320      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5321      & dt_dCi(3),dt_dCi1(3)
5322       common /sccalc/ time11,time12,time112,theti,it,nlobit
5323       delta=0.02d0*pi
5324       escloc=0.0D0
5325       do i=loc_start,loc_end
5326         if (itype(i).eq.ntyp1) cycle
5327         costtab(i+1) =dcos(theta(i+1))
5328         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5329         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5330         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5331         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5332         cosfac=dsqrt(cosfac2)
5333         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5334         sinfac=dsqrt(sinfac2)
5335         it=iabs(itype(i))
5336         if (it.eq.10) goto 1
5337 c
5338 C  Compute the axes of tghe local cartesian coordinates system; store in
5339 c   x_prime, y_prime and z_prime
5340 c
5341         do j=1,3
5342           x_prime(j) = 0.00
5343           y_prime(j) = 0.00
5344           z_prime(j) = 0.00
5345         enddo
5346 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5347 C     &   dc_norm(3,i+nres)
5348         do j = 1,3
5349           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5350           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5351         enddo
5352         do j = 1,3
5353           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5354         enddo
5355 c       write (2,*) "i",i
5356 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5357 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5358 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5359 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5360 c      & " xy",scalar(x_prime(1),y_prime(1)),
5361 c      & " xz",scalar(x_prime(1),z_prime(1)),
5362 c      & " yy",scalar(y_prime(1),y_prime(1)),
5363 c      & " yz",scalar(y_prime(1),z_prime(1)),
5364 c      & " zz",scalar(z_prime(1),z_prime(1))
5365 c
5366 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5367 C to local coordinate system. Store in xx, yy, zz.
5368 c
5369         xx=0.0d0
5370         yy=0.0d0
5371         zz=0.0d0
5372         do j = 1,3
5373           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5374           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5375           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5376         enddo
5377
5378         xxtab(i)=xx
5379         yytab(i)=yy
5380         zztab(i)=zz
5381 C
5382 C Compute the energy of the ith side cbain
5383 C
5384 c        write (2,*) "xx",xx," yy",yy," zz",zz
5385         it=iabs(itype(i))
5386         do j = 1,65
5387           x(j) = sc_parmin(j,it)
5388         enddo
5389 #ifdef CHECK_COORD
5390 Cc diagnostics - remove later
5391         xx1 = dcos(alph(2))
5392         yy1 = dsin(alph(2))*dcos(omeg(2))
5393         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5394         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5395      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5396      &    xx1,yy1,zz1
5397 C,"  --- ", xx_w,yy_w,zz_w
5398 c end diagnostics
5399 #endif
5400         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5401      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5402      &   + x(10)*yy*zz
5403         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5404      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5405      & + x(20)*yy*zz
5406         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5407      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5408      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5409      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5410      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5411      &  +x(40)*xx*yy*zz
5412         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5413      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5414      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5415      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5416      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5417      &  +x(60)*xx*yy*zz
5418         dsc_i   = 0.743d0+x(61)
5419         dp2_i   = 1.9d0+x(62)
5420         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5421      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5422         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5423      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5424         s1=(1+x(63))/(0.1d0 + dscp1)
5425         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5426         s2=(1+x(65))/(0.1d0 + dscp2)
5427         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5428         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5429      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5430 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5431 c     &   sumene4,
5432 c     &   dscp1,dscp2,sumene
5433 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5434         escloc = escloc + sumene
5435 c        write (2,*) "escloc",escloc
5436 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5437 c     &  zz,xx,yy
5438         if (.not. calc_grad) goto 1
5439 #ifdef DEBUG
5440 C
5441 C This section to check the numerical derivatives of the energy of ith side
5442 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5443 C #define DEBUG in the code to turn it on.
5444 C
5445         write (2,*) "sumene               =",sumene
5446         aincr=1.0d-7
5447         xxsave=xx
5448         xx=xx+aincr
5449         write (2,*) xx,yy,zz
5450         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5451         de_dxx_num=(sumenep-sumene)/aincr
5452         xx=xxsave
5453         write (2,*) "xx+ sumene from enesc=",sumenep
5454         yysave=yy
5455         yy=yy+aincr
5456         write (2,*) xx,yy,zz
5457         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5458         de_dyy_num=(sumenep-sumene)/aincr
5459         yy=yysave
5460         write (2,*) "yy+ sumene from enesc=",sumenep
5461         zzsave=zz
5462         zz=zz+aincr
5463         write (2,*) xx,yy,zz
5464         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5465         de_dzz_num=(sumenep-sumene)/aincr
5466         zz=zzsave
5467         write (2,*) "zz+ sumene from enesc=",sumenep
5468         costsave=cost2tab(i+1)
5469         sintsave=sint2tab(i+1)
5470         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5471         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5472         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5473         de_dt_num=(sumenep-sumene)/aincr
5474         write (2,*) " t+ sumene from enesc=",sumenep
5475         cost2tab(i+1)=costsave
5476         sint2tab(i+1)=sintsave
5477 C End of diagnostics section.
5478 #endif
5479 C
5480 C Compute the gradient of esc
5481 C
5482         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5483         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5484         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5485         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5486         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5487         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5488         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5489         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5490         pom1=(sumene3*sint2tab(i+1)+sumene1)
5491      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5492         pom2=(sumene4*cost2tab(i+1)+sumene2)
5493      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5494         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5495         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5496      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5497      &  +x(40)*yy*zz
5498         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5499         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5500      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5501      &  +x(60)*yy*zz
5502         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5503      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5504      &        +(pom1+pom2)*pom_dx
5505 #ifdef DEBUG
5506         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5507 #endif
5508 C
5509         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5510         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5511      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5512      &  +x(40)*xx*zz
5513         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5514         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5515      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5516      &  +x(59)*zz**2 +x(60)*xx*zz
5517         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5518      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5519      &        +(pom1-pom2)*pom_dy
5520 #ifdef DEBUG
5521         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5522 #endif
5523 C
5524         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5525      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5526      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5527      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5528      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5529      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5530      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5531      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5532 #ifdef DEBUG
5533         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5534 #endif
5535 C
5536         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5537      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5538      &  +pom1*pom_dt1+pom2*pom_dt2
5539 #ifdef DEBUG
5540         write(2,*), "de_dt = ", de_dt,de_dt_num
5541 #endif
5542 c
5543 C
5544        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5545        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5546        cosfac2xx=cosfac2*xx
5547        sinfac2yy=sinfac2*yy
5548        do k = 1,3
5549          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5550      &      vbld_inv(i+1)
5551          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5552      &      vbld_inv(i)
5553          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5554          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5555 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5556 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5557 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5558 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5559          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5560          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5561          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5562          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5563          dZZ_Ci1(k)=0.0d0
5564          dZZ_Ci(k)=0.0d0
5565          do j=1,3
5566            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5567      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5568            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5569      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5570          enddo
5571
5572          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5573          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5574          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5575 c
5576          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5577          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5578        enddo
5579
5580        do k=1,3
5581          dXX_Ctab(k,i)=dXX_Ci(k)
5582          dXX_C1tab(k,i)=dXX_Ci1(k)
5583          dYY_Ctab(k,i)=dYY_Ci(k)
5584          dYY_C1tab(k,i)=dYY_Ci1(k)
5585          dZZ_Ctab(k,i)=dZZ_Ci(k)
5586          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5587          dXX_XYZtab(k,i)=dXX_XYZ(k)
5588          dYY_XYZtab(k,i)=dYY_XYZ(k)
5589          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5590        enddo
5591
5592        do k = 1,3
5593 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5594 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5595 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5596 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5597 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5598 c     &    dt_dci(k)
5599 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5600 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5601          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5602      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5603          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5604      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5605          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5606      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5607        enddo
5608 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5609 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5610
5611 C to check gradient call subroutine check_grad
5612
5613     1 continue
5614       enddo
5615       return
5616       end
5617 #endif
5618 c------------------------------------------------------------------------------
5619       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5620 C
5621 C This procedure calculates two-body contact function g(rij) and its derivative:
5622 C
5623 C           eps0ij                                     !       x < -1
5624 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5625 C            0                                         !       x > 1
5626 C
5627 C where x=(rij-r0ij)/delta
5628 C
5629 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5630 C
5631       implicit none
5632       double precision rij,r0ij,eps0ij,fcont,fprimcont
5633       double precision x,x2,x4,delta
5634 c     delta=0.02D0*r0ij
5635 c      delta=0.2D0*r0ij
5636       x=(rij-r0ij)/delta
5637       if (x.lt.-1.0D0) then
5638         fcont=eps0ij
5639         fprimcont=0.0D0
5640       else if (x.le.1.0D0) then
5641         x2=x*x
5642         x4=x2*x2
5643         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5644         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5645       else
5646         fcont=0.0D0
5647         fprimcont=0.0D0
5648       endif
5649       return
5650       end
5651 c------------------------------------------------------------------------------
5652       subroutine splinthet(theti,delta,ss,ssder)
5653       implicit real*8 (a-h,o-z)
5654       include 'DIMENSIONS'
5655       include 'COMMON.VAR'
5656       include 'COMMON.GEO'
5657       thetup=pi-delta
5658       thetlow=delta
5659       if (theti.gt.pipol) then
5660         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5661       else
5662         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5663         ssder=-ssder
5664       endif
5665       return
5666       end
5667 c------------------------------------------------------------------------------
5668       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5669       implicit none
5670       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5671       double precision ksi,ksi2,ksi3,a1,a2,a3
5672       a1=fprim0*delta/(f1-f0)
5673       a2=3.0d0-2.0d0*a1
5674       a3=a1-2.0d0
5675       ksi=(x-x0)/delta
5676       ksi2=ksi*ksi
5677       ksi3=ksi2*ksi
5678       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5679       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5680       return
5681       end
5682 c------------------------------------------------------------------------------
5683       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5684       implicit none
5685       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5686       double precision ksi,ksi2,ksi3,a1,a2,a3
5687       ksi=(x-x0)/delta
5688       ksi2=ksi*ksi
5689       ksi3=ksi2*ksi
5690       a1=fprim0x*delta
5691       a2=3*(f1x-f0x)-2*fprim0x*delta
5692       a3=fprim0x*delta-2*(f1x-f0x)
5693       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5694       return
5695       end
5696 C-----------------------------------------------------------------------------
5697 #ifdef CRYST_TOR
5698 C-----------------------------------------------------------------------------
5699       subroutine etor(etors,fact)
5700       implicit real*8 (a-h,o-z)
5701       include 'DIMENSIONS'
5702       include 'COMMON.VAR'
5703       include 'COMMON.GEO'
5704       include 'COMMON.LOCAL'
5705       include 'COMMON.TORSION'
5706       include 'COMMON.INTERACT'
5707       include 'COMMON.DERIV'
5708       include 'COMMON.CHAIN'
5709       include 'COMMON.NAMES'
5710       include 'COMMON.IOUNITS'
5711       include 'COMMON.FFIELD'
5712       include 'COMMON.TORCNSTR'
5713       logical lprn
5714 C Set lprn=.true. for debugging
5715       lprn=.false.
5716 c      lprn=.true.
5717       etors=0.0D0
5718       do i=iphi_start,iphi_end
5719         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5720      &      .or. itype(i).eq.ntyp1) cycle
5721         itori=itortyp(itype(i-2))
5722         itori1=itortyp(itype(i-1))
5723         phii=phi(i)
5724         gloci=0.0D0
5725 C Proline-Proline pair is a special case...
5726         if (itori.eq.3 .and. itori1.eq.3) then
5727           if (phii.gt.-dwapi3) then
5728             cosphi=dcos(3*phii)
5729             fac=1.0D0/(1.0D0-cosphi)
5730             etorsi=v1(1,3,3)*fac
5731             etorsi=etorsi+etorsi
5732             etors=etors+etorsi-v1(1,3,3)
5733             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5734           endif
5735           do j=1,3
5736             v1ij=v1(j+1,itori,itori1)
5737             v2ij=v2(j+1,itori,itori1)
5738             cosphi=dcos(j*phii)
5739             sinphi=dsin(j*phii)
5740             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5741             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5742           enddo
5743         else
5744           do j=1,nterm_old
5745             v1ij=v1(j,itori,itori1)
5746             v2ij=v2(j,itori,itori1)
5747             cosphi=dcos(j*phii)
5748             sinphi=dsin(j*phii)
5749             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5750             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5751           enddo
5752         endif
5753         if (lprn)
5754      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5755      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5756      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5757         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5758 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5759       enddo
5760       return
5761       end
5762 c------------------------------------------------------------------------------
5763 #else
5764       subroutine etor(etors,fact)
5765       implicit real*8 (a-h,o-z)
5766       include 'DIMENSIONS'
5767       include 'COMMON.VAR'
5768       include 'COMMON.GEO'
5769       include 'COMMON.LOCAL'
5770       include 'COMMON.TORSION'
5771       include 'COMMON.INTERACT'
5772       include 'COMMON.DERIV'
5773       include 'COMMON.CHAIN'
5774       include 'COMMON.NAMES'
5775       include 'COMMON.IOUNITS'
5776       include 'COMMON.FFIELD'
5777       include 'COMMON.TORCNSTR'
5778       logical lprn
5779 C Set lprn=.true. for debugging
5780       lprn=.false.
5781 c      lprn=.true.
5782       etors=0.0D0
5783       do i=iphi_start,iphi_end
5784         if (i.le.2) cycle
5785         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5786      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5787 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5788 C     &       .or. itype(i).eq.ntyp1) cycle
5789         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5790          if (iabs(itype(i)).eq.20) then
5791          iblock=2
5792          else
5793          iblock=1
5794          endif
5795         itori=itortyp(itype(i-2))
5796         itori1=itortyp(itype(i-1))
5797         phii=phi(i)
5798         gloci=0.0D0
5799 C Regular cosine and sine terms
5800         do j=1,nterm(itori,itori1,iblock)
5801           v1ij=v1(j,itori,itori1,iblock)
5802           v2ij=v2(j,itori,itori1,iblock)
5803           cosphi=dcos(j*phii)
5804           sinphi=dsin(j*phii)
5805           etors=etors+v1ij*cosphi+v2ij*sinphi
5806           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5807         enddo
5808 C Lorentz terms
5809 C                         v1
5810 C  E = SUM ----------------------------------- - v1
5811 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5812 C
5813         cosphi=dcos(0.5d0*phii)
5814         sinphi=dsin(0.5d0*phii)
5815         do j=1,nlor(itori,itori1,iblock)
5816           vl1ij=vlor1(j,itori,itori1)
5817           vl2ij=vlor2(j,itori,itori1)
5818           vl3ij=vlor3(j,itori,itori1)
5819           pom=vl2ij*cosphi+vl3ij*sinphi
5820           pom1=1.0d0/(pom*pom+1.0d0)
5821           etors=etors+vl1ij*pom1
5822 c          if (energy_dec) etors_ii=etors_ii+
5823 c     &                vl1ij*pom1
5824           pom=-pom*pom1*pom1
5825           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5826         enddo
5827 C Subtract the constant term
5828         etors=etors-v0(itori,itori1,iblock)
5829         if (lprn)
5830      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5831      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5832      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5833         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5834 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5835  1215   continue
5836       enddo
5837       return
5838       end
5839 c----------------------------------------------------------------------------
5840       subroutine etor_d(etors_d,fact2)
5841 C 6/23/01 Compute double torsional energy
5842       implicit real*8 (a-h,o-z)
5843       include 'DIMENSIONS'
5844       include 'COMMON.VAR'
5845       include 'COMMON.GEO'
5846       include 'COMMON.LOCAL'
5847       include 'COMMON.TORSION'
5848       include 'COMMON.INTERACT'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.CHAIN'
5851       include 'COMMON.NAMES'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.FFIELD'
5854       include 'COMMON.TORCNSTR'
5855       logical lprn
5856 C Set lprn=.true. for debugging
5857       lprn=.false.
5858 c     lprn=.true.
5859       etors_d=0.0D0
5860       do i=iphi_start,iphi_end-1
5861         if (i.le.3) cycle
5862 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5863 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5864          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5865      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5866      &  (itype(i+1).eq.ntyp1)) cycle
5867         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5868      &     goto 1215
5869         itori=itortyp(itype(i-2))
5870         itori1=itortyp(itype(i-1))
5871         itori2=itortyp(itype(i))
5872         phii=phi(i)
5873         phii1=phi(i+1)
5874         gloci1=0.0D0
5875         gloci2=0.0D0
5876         iblock=1
5877         if (iabs(itype(i+1)).eq.20) iblock=2
5878 C Regular cosine and sine terms
5879         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5880           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5881           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5882           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5883           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5884           cosphi1=dcos(j*phii)
5885           sinphi1=dsin(j*phii)
5886           cosphi2=dcos(j*phii1)
5887           sinphi2=dsin(j*phii1)
5888           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5889      &     v2cij*cosphi2+v2sij*sinphi2
5890           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5891           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5892         enddo
5893         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5894           do l=1,k-1
5895             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5896             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5897             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5898             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5899             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5900             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5901             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5902             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5903             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5904      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5905             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5906      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5907             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5908      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5909           enddo
5910         enddo
5911         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5912         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5913  1215   continue
5914       enddo
5915       return
5916       end
5917 #endif
5918 c---------------------------------------------------------------------------
5919 C The rigorous attempt to derive energy function
5920       subroutine etor_kcc(etors,fact)
5921       implicit real*8 (a-h,o-z)
5922       include 'DIMENSIONS'
5923       include 'COMMON.VAR'
5924       include 'COMMON.GEO'
5925       include 'COMMON.LOCAL'
5926       include 'COMMON.TORSION'
5927       include 'COMMON.INTERACT'
5928       include 'COMMON.DERIV'
5929       include 'COMMON.CHAIN'
5930       include 'COMMON.NAMES'
5931       include 'COMMON.IOUNITS'
5932       include 'COMMON.FFIELD'
5933       include 'COMMON.TORCNSTR'
5934       include 'COMMON.CONTROL'
5935       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5936       logical lprn
5937 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5938 C Set lprn=.true. for debugging
5939       lprn=energy_dec
5940 c     lprn=.true.
5941 C      print *,"wchodze kcc"
5942       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5943       etors=0.0D0
5944       do i=iphi_start,iphi_end
5945 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5946 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5947 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5948 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5949         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5950      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5951         itori=itortyp(itype(i-2))
5952         itori1=itortyp(itype(i-1))
5953         phii=phi(i)
5954         glocig=0.0D0
5955         glocit1=0.0d0
5956         glocit2=0.0d0
5957 C to avoid multiple devision by 2
5958 c        theti22=0.5d0*theta(i)
5959 C theta 12 is the theta_1 /2
5960 C theta 22 is theta_2 /2
5961 c        theti12=0.5d0*theta(i-1)
5962 C and appropriate sinus function
5963         sinthet1=dsin(theta(i-1))
5964         sinthet2=dsin(theta(i))
5965         costhet1=dcos(theta(i-1))
5966         costhet2=dcos(theta(i))
5967 C to speed up lets store its mutliplication
5968         sint1t2=sinthet2*sinthet1
5969         sint1t2n=1.0d0
5970 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5971 C +d_n*sin(n*gamma)) *
5972 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5973 C we have two sum 1) Non-Chebyshev which is with n and gamma
5974         nval=nterm_kcc_Tb(itori,itori1)
5975         c1(0)=0.0d0
5976         c2(0)=0.0d0
5977         c1(1)=1.0d0
5978         c2(1)=1.0d0
5979         do j=2,nval
5980           c1(j)=c1(j-1)*costhet1
5981           c2(j)=c2(j-1)*costhet2
5982         enddo
5983         etori=0.0d0
5984         do j=1,nterm_kcc(itori,itori1)
5985           cosphi=dcos(j*phii)
5986           sinphi=dsin(j*phii)
5987           sint1t2n1=sint1t2n
5988           sint1t2n=sint1t2n*sint1t2
5989           sumvalc=0.0d0
5990           gradvalct1=0.0d0
5991           gradvalct2=0.0d0
5992           do k=1,nval
5993             do l=1,nval
5994               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5995               gradvalct1=gradvalct1+
5996      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5997               gradvalct2=gradvalct2+
5998      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5999             enddo
6000           enddo
6001           gradvalct1=-gradvalct1*sinthet1
6002           gradvalct2=-gradvalct2*sinthet2
6003           sumvals=0.0d0
6004           gradvalst1=0.0d0
6005           gradvalst2=0.0d0
6006           do k=1,nval
6007             do l=1,nval
6008               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6009               gradvalst1=gradvalst1+
6010      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6011               gradvalst2=gradvalst2+
6012      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6013             enddo
6014           enddo
6015           gradvalst1=-gradvalst1*sinthet1
6016           gradvalst2=-gradvalst2*sinthet2
6017           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6018 C glocig is the gradient local i site in gamma
6019           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6020 C now gradient over theta_1
6021           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6022      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6023           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6024      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6025         enddo ! j
6026         etors=etors+etori
6027 C derivative over gamma
6028         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6029 C derivative over theta1
6030         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6031 C now derivative over theta2
6032         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6033         if (lprn)
6034      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6035      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6036       enddo
6037       return
6038       end
6039 c---------------------------------------------------------------------------------------------
6040       subroutine etor_constr(edihcnstr)
6041       implicit real*8 (a-h,o-z)
6042       include 'DIMENSIONS'
6043       include 'COMMON.VAR'
6044       include 'COMMON.GEO'
6045       include 'COMMON.LOCAL'
6046       include 'COMMON.TORSION'
6047       include 'COMMON.INTERACT'
6048       include 'COMMON.DERIV'
6049       include 'COMMON.CHAIN'
6050       include 'COMMON.NAMES'
6051       include 'COMMON.IOUNITS'
6052       include 'COMMON.FFIELD'
6053       include 'COMMON.TORCNSTR'
6054       include 'COMMON.CONTROL'
6055 ! 6/20/98 - dihedral angle constraints
6056       edihcnstr=0.0d0
6057 c      do i=1,ndih_constr
6058 c      write (iout,*) "idihconstr_start",idihconstr_start,
6059 c     &  " idihconstr_end",idihconstr_end
6060       if (raw_psipred) then
6061         do i=idihconstr_start,idihconstr_end
6062           itori=idih_constr(i)
6063           phii=phi(itori)
6064           gaudih_i=vpsipred(1,i)
6065           gauder_i=0.0d0
6066           do j=1,2
6067             s = sdihed(j,i)
6068             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6069             dexpcos_i=dexp(-cos_i*cos_i)
6070             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6071             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6072      &            *cos_i*dexpcos_i/s**2
6073           enddo
6074           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6075           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6076           if (energy_dec)
6077      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6078      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6079      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6080      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6081      &     -wdihc*dlog(gaudih_i)
6082         enddo
6083       else
6084         do i=idihconstr_start,idihconstr_end
6085           itori=idih_constr(i)
6086           phii=phi(itori)
6087           difi=pinorm(phii-phi0(i))
6088           if (difi.gt.drange(i)) then
6089             difi=difi-drange(i)
6090             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6091             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6092           else if (difi.lt.-drange(i)) then
6093             difi=difi+drange(i)
6094             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6095             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6096           else
6097             difi=0.0
6098           endif
6099         enddo
6100       endif
6101       return
6102       end
6103 c----------------------------------------------------------------------------
6104 C The rigorous attempt to derive energy function
6105       subroutine ebend_kcc(etheta)
6106
6107       implicit real*8 (a-h,o-z)
6108       include 'DIMENSIONS'
6109       include 'COMMON.VAR'
6110       include 'COMMON.GEO'
6111       include 'COMMON.LOCAL'
6112       include 'COMMON.TORSION'
6113       include 'COMMON.INTERACT'
6114       include 'COMMON.DERIV'
6115       include 'COMMON.CHAIN'
6116       include 'COMMON.NAMES'
6117       include 'COMMON.IOUNITS'
6118       include 'COMMON.FFIELD'
6119       include 'COMMON.TORCNSTR'
6120       include 'COMMON.CONTROL'
6121       logical lprn
6122       double precision thybt1(maxang_kcc)
6123 C Set lprn=.true. for debugging
6124       lprn=energy_dec
6125 c     lprn=.true.
6126 C      print *,"wchodze kcc"
6127       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6128       etheta=0.0D0
6129       do i=ithet_start,ithet_end
6130 c        print *,i,itype(i-1),itype(i),itype(i-2)
6131         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6132      &  .or.itype(i).eq.ntyp1) cycle
6133         iti=iabs(itortyp(itype(i-1)))
6134         sinthet=dsin(theta(i))
6135         costhet=dcos(theta(i))
6136         do j=1,nbend_kcc_Tb(iti)
6137           thybt1(j)=v1bend_chyb(j,iti)
6138         enddo
6139         sumth1thyb=v1bend_chyb(0,iti)+
6140      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6141         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6142      &    sumth1thyb
6143         ihelp=nbend_kcc_Tb(iti)-1
6144         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6145         etheta=etheta+sumth1thyb
6146 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6147         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6148       enddo
6149       return
6150       end
6151 c-------------------------------------------------------------------------------------
6152       subroutine etheta_constr(ethetacnstr)
6153
6154       implicit real*8 (a-h,o-z)
6155       include 'DIMENSIONS'
6156       include 'COMMON.VAR'
6157       include 'COMMON.GEO'
6158       include 'COMMON.LOCAL'
6159       include 'COMMON.TORSION'
6160       include 'COMMON.INTERACT'
6161       include 'COMMON.DERIV'
6162       include 'COMMON.CHAIN'
6163       include 'COMMON.NAMES'
6164       include 'COMMON.IOUNITS'
6165       include 'COMMON.FFIELD'
6166       include 'COMMON.TORCNSTR'
6167       include 'COMMON.CONTROL'
6168       ethetacnstr=0.0d0
6169 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6170       do i=ithetaconstr_start,ithetaconstr_end
6171         itheta=itheta_constr(i)
6172         thetiii=theta(itheta)
6173         difi=pinorm(thetiii-theta_constr0(i))
6174         if (difi.gt.theta_drange(i)) then
6175           difi=difi-theta_drange(i)
6176           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6177           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6178      &    +for_thet_constr(i)*difi**3
6179         else if (difi.lt.-drange(i)) then
6180           difi=difi+drange(i)
6181           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6182           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6183      &    +for_thet_constr(i)*difi**3
6184         else
6185           difi=0.0
6186         endif
6187        if (energy_dec) then
6188         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6189      &    i,itheta,rad2deg*thetiii,
6190      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6191      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6192      &    gloc(itheta+nphi-2,icg)
6193         endif
6194       enddo
6195       return
6196       end
6197 c------------------------------------------------------------------------------
6198 c------------------------------------------------------------------------------
6199       subroutine eback_sc_corr(esccor)
6200 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6201 c        conformational states; temporarily implemented as differences
6202 c        between UNRES torsional potentials (dependent on three types of
6203 c        residues) and the torsional potentials dependent on all 20 types
6204 c        of residues computed from AM1 energy surfaces of terminally-blocked
6205 c        amino-acid residues.
6206       implicit real*8 (a-h,o-z)
6207       include 'DIMENSIONS'
6208       include 'COMMON.VAR'
6209       include 'COMMON.GEO'
6210       include 'COMMON.LOCAL'
6211       include 'COMMON.TORSION'
6212       include 'COMMON.SCCOR'
6213       include 'COMMON.INTERACT'
6214       include 'COMMON.DERIV'
6215       include 'COMMON.CHAIN'
6216       include 'COMMON.NAMES'
6217       include 'COMMON.IOUNITS'
6218       include 'COMMON.FFIELD'
6219       include 'COMMON.CONTROL'
6220       logical lprn
6221 C Set lprn=.true. for debugging
6222       lprn=.false.
6223 c      lprn=.true.
6224 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6225       esccor=0.0D0
6226       do i=itau_start,itau_end
6227         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6228         esccor_ii=0.0D0
6229         isccori=isccortyp(itype(i-2))
6230         isccori1=isccortyp(itype(i-1))
6231         phii=phi(i)
6232         do intertyp=1,3 !intertyp
6233 cc Added 09 May 2012 (Adasko)
6234 cc  Intertyp means interaction type of backbone mainchain correlation:
6235 c   1 = SC...Ca...Ca...Ca
6236 c   2 = Ca...Ca...Ca...SC
6237 c   3 = SC...Ca...Ca...SCi
6238         gloci=0.0D0
6239         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6240      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6241      &      (itype(i-1).eq.ntyp1)))
6242      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6243      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6244      &     .or.(itype(i).eq.ntyp1)))
6245      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6246      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6247      &      (itype(i-3).eq.ntyp1)))) cycle
6248         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6249         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6250      & cycle
6251        do j=1,nterm_sccor(isccori,isccori1)
6252           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6253           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6254           cosphi=dcos(j*tauangle(intertyp,i))
6255           sinphi=dsin(j*tauangle(intertyp,i))
6256            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6257            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6258          enddo
6259 C      write (iout,*)"EBACK_SC_COR",esccor,i
6260 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6261 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6262 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6263         if (lprn)
6264      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6265      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6266      &  (v1sccor(j,1,itori,itori1),j=1,6)
6267      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6268 c        gsccor_loc(i-3)=gloci
6269        enddo !intertyp
6270       enddo
6271       return
6272       end
6273 c------------------------------------------------------------------------------
6274       subroutine multibody(ecorr)
6275 C This subroutine calculates multi-body contributions to energy following
6276 C the idea of Skolnick et al. If side chains I and J make a contact and
6277 C at the same time side chains I+1 and J+1 make a contact, an extra
6278 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6279       implicit real*8 (a-h,o-z)
6280       include 'DIMENSIONS'
6281       include 'COMMON.IOUNITS'
6282       include 'COMMON.DERIV'
6283       include 'COMMON.INTERACT'
6284       include 'COMMON.CONTACTS'
6285       double precision gx(3),gx1(3)
6286       logical lprn
6287
6288 C Set lprn=.true. for debugging
6289       lprn=.false.
6290
6291       if (lprn) then
6292         write (iout,'(a)') 'Contact function values:'
6293         do i=nnt,nct-2
6294           write (iout,'(i2,20(1x,i2,f10.5))')
6295      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6296         enddo
6297       endif
6298       ecorr=0.0D0
6299       do i=nnt,nct
6300         do j=1,3
6301           gradcorr(j,i)=0.0D0
6302           gradxorr(j,i)=0.0D0
6303         enddo
6304       enddo
6305       do i=nnt,nct-2
6306
6307         DO ISHIFT = 3,4
6308
6309         i1=i+ishift
6310         num_conti=num_cont(i)
6311         num_conti1=num_cont(i1)
6312         do jj=1,num_conti
6313           j=jcont(jj,i)
6314           do kk=1,num_conti1
6315             j1=jcont(kk,i1)
6316             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6317 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6318 cd   &                   ' ishift=',ishift
6319 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6320 C The system gains extra energy.
6321               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6322             endif   ! j1==j+-ishift
6323           enddo     ! kk
6324         enddo       ! jj
6325
6326         ENDDO ! ISHIFT
6327
6328       enddo         ! i
6329       return
6330       end
6331 c------------------------------------------------------------------------------
6332       double precision function esccorr(i,j,k,l,jj,kk)
6333       implicit real*8 (a-h,o-z)
6334       include 'DIMENSIONS'
6335       include 'COMMON.IOUNITS'
6336       include 'COMMON.DERIV'
6337       include 'COMMON.INTERACT'
6338       include 'COMMON.CONTACTS'
6339       double precision gx(3),gx1(3)
6340       logical lprn
6341       lprn=.false.
6342       eij=facont(jj,i)
6343       ekl=facont(kk,k)
6344 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6345 C Calculate the multi-body contribution to energy.
6346 C Calculate multi-body contributions to the gradient.
6347 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6348 cd   & k,l,(gacont(m,kk,k),m=1,3)
6349       do m=1,3
6350         gx(m) =ekl*gacont(m,jj,i)
6351         gx1(m)=eij*gacont(m,kk,k)
6352         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6353         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6354         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6355         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6356       enddo
6357       do m=i,j-1
6358         do ll=1,3
6359           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6360         enddo
6361       enddo
6362       do m=k,l-1
6363         do ll=1,3
6364           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6365         enddo
6366       enddo
6367       esccorr=-eij*ekl
6368       return
6369       end
6370 c------------------------------------------------------------------------------
6371       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6372 C This subroutine calculates multi-body contributions to hydrogen-bonding
6373       implicit real*8 (a-h,o-z)
6374       include 'DIMENSIONS'
6375       include 'COMMON.IOUNITS'
6376       include 'COMMON.FFIELD'
6377       include 'COMMON.DERIV'
6378       include 'COMMON.INTERACT'
6379       include 'COMMON.CONTACTS'
6380       double precision gx(3),gx1(3)
6381       logical lprn,ldone
6382
6383 C Set lprn=.true. for debugging
6384       lprn=.false.
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i2,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392       endif
6393       ecorr=0.0D0
6394 C Remove the loop below after debugging !!!
6395       do i=nnt,nct
6396         do j=1,3
6397           gradcorr(j,i)=0.0D0
6398           gradxorr(j,i)=0.0D0
6399         enddo
6400       enddo
6401 C Calculate the local-electrostatic correlation terms
6402       do i=iatel_s,iatel_e+1
6403         i1=i+1
6404         num_conti=num_cont_hb(i)
6405         num_conti1=num_cont_hb(i+1)
6406         do jj=1,num_conti
6407           j=jcont_hb(jj,i)
6408           do kk=1,num_conti1
6409             j1=jcont_hb(kk,i1)
6410 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6411 c     &         ' jj=',jj,' kk=',kk
6412             if (j1.eq.j+1 .or. j1.eq.j-1) then
6413 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6414 C The system gains extra energy.
6415               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6416               n_corr=n_corr+1
6417             else if (j1.eq.j) then
6418 C Contacts I-J and I-(J+1) occur simultaneously.
6419 C The system loses extra energy.
6420 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6421             endif
6422           enddo ! kk
6423           do kk=1,num_conti
6424             j1=jcont_hb(kk,i)
6425 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6426 c    &         ' jj=',jj,' kk=',kk
6427             if (j1.eq.j+1) then
6428 C Contacts I-J and (I+1)-J occur simultaneously.
6429 C The system loses extra energy.
6430 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6431             endif ! j1==j+1
6432           enddo ! kk
6433         enddo ! jj
6434       enddo ! i
6435       return
6436       end
6437 c------------------------------------------------------------------------------
6438       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6439      &  n_corr1)
6440 C This subroutine calculates multi-body contributions to hydrogen-bonding
6441       implicit real*8 (a-h,o-z)
6442       include 'DIMENSIONS'
6443       include 'COMMON.IOUNITS'
6444 #ifdef MPI
6445       include "mpif.h"
6446 #endif
6447       include 'COMMON.FFIELD'
6448       include 'COMMON.DERIV'
6449       include 'COMMON.LOCAL'
6450       include 'COMMON.INTERACT'
6451       include 'COMMON.CONTACTS'
6452       include 'COMMON.CHAIN'
6453       include 'COMMON.CONTROL'
6454       include 'COMMON.SHIELD'
6455       double precision gx(3),gx1(3)
6456       integer num_cont_hb_old(maxres)
6457       logical lprn,ldone
6458       double precision eello4,eello5,eelo6,eello_turn6
6459       external eello4,eello5,eello6,eello_turn6
6460 C Set lprn=.true. for debugging
6461       lprn=.false.
6462       eturn6=0.0d0
6463       if (lprn) then
6464         write (iout,'(a)') 'Contact function values:'
6465         do i=nnt,nct-2
6466           write (iout,'(2i3,50(1x,i2,5f6.3))')
6467      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6468      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6469         enddo
6470       endif
6471       ecorr=0.0D0
6472       ecorr5=0.0d0
6473       ecorr6=0.0d0
6474 C Remove the loop below after debugging !!!
6475       do i=nnt,nct
6476         do j=1,3
6477           gradcorr(j,i)=0.0D0
6478           gradxorr(j,i)=0.0D0
6479         enddo
6480       enddo
6481 C Calculate the dipole-dipole interaction energies
6482       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6483       do i=iatel_s,iatel_e+1
6484         num_conti=num_cont_hb(i)
6485         do jj=1,num_conti
6486           j=jcont_hb(jj,i)
6487 #ifdef MOMENT
6488           call dipole(i,j,jj)
6489 #endif
6490         enddo
6491       enddo
6492       endif
6493 C Calculate the local-electrostatic correlation terms
6494 c                write (iout,*) "gradcorr5 in eello5 before loop"
6495 c                do iii=1,nres
6496 c                  write (iout,'(i5,3f10.5)')
6497 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6498 c                enddo
6499       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6500 c        write (iout,*) "corr loop i",i
6501         i1=i+1
6502         num_conti=num_cont_hb(i)
6503         num_conti1=num_cont_hb(i+1)
6504         do jj=1,num_conti
6505           j=jcont_hb(jj,i)
6506           jp=iabs(j)
6507           do kk=1,num_conti1
6508             j1=jcont_hb(kk,i1)
6509             jp1=iabs(j1)
6510 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6511 c     &         ' jj=',jj,' kk=',kk
6512 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6513             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6514      &          .or. j.lt.0 .and. j1.gt.0) .and.
6515      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6516 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6517 C The system gains extra energy.
6518               n_corr=n_corr+1
6519               sqd1=dsqrt(d_cont(jj,i))
6520               sqd2=dsqrt(d_cont(kk,i1))
6521               sred_geom = sqd1*sqd2
6522               IF (sred_geom.lt.cutoff_corr) THEN
6523                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6524      &            ekont,fprimcont)
6525 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6526 cd     &         ' jj=',jj,' kk=',kk
6527                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6528                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6529                 do l=1,3
6530                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6531                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6532                 enddo
6533                 n_corr1=n_corr1+1
6534 cd               write (iout,*) 'sred_geom=',sred_geom,
6535 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6536 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6537 cd               write (iout,*) "g_contij",g_contij
6538 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6539 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6540                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6541                 if (wcorr4.gt.0.0d0)
6542      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6543 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6544                   if (energy_dec.and.wcorr4.gt.0.0d0)
6545      1                 write (iout,'(a6,4i5,0pf7.3)')
6546      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6547 c                write (iout,*) "gradcorr5 before eello5"
6548 c                do iii=1,nres
6549 c                  write (iout,'(i5,3f10.5)')
6550 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6551 c                enddo
6552                 if (wcorr5.gt.0.0d0)
6553      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6554 c                write (iout,*) "gradcorr5 after eello5"
6555 c                do iii=1,nres
6556 c                  write (iout,'(i5,3f10.5)')
6557 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6558 c                enddo
6559                   if (energy_dec.and.wcorr5.gt.0.0d0)
6560      1                 write (iout,'(a6,4i5,0pf7.3)')
6561      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6562 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6563 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6564                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6565      &               .or. wturn6.eq.0.0d0))then
6566 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6567                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6568                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6569      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6570 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6571 cd     &            'ecorr6=',ecorr6
6572 cd                write (iout,'(4e15.5)') sred_geom,
6573 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6574 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6575 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6576                 else if (wturn6.gt.0.0d0
6577      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6578 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6579                   eturn6=eturn6+eello_turn6(i,jj,kk)
6580                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6581      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6582 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6583                 endif
6584               ENDIF
6585 1111          continue
6586             endif
6587           enddo ! kk
6588         enddo ! jj
6589       enddo ! i
6590       do i=1,nres
6591         num_cont_hb(i)=num_cont_hb_old(i)
6592       enddo
6593 c                write (iout,*) "gradcorr5 in eello5"
6594 c                do iii=1,nres
6595 c                  write (iout,'(i5,3f10.5)')
6596 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6597 c                enddo
6598       return
6599       end
6600 c------------------------------------------------------------------------------
6601       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6602       implicit real*8 (a-h,o-z)
6603       include 'DIMENSIONS'
6604       include 'COMMON.IOUNITS'
6605       include 'COMMON.DERIV'
6606       include 'COMMON.INTERACT'
6607       include 'COMMON.CONTACTS'
6608       include 'COMMON.SHIELD'
6609       include 'COMMON.CONTROL'
6610       double precision gx(3),gx1(3)
6611       logical lprn
6612       lprn=.false.
6613 C      print *,"wchodze",fac_shield(i),shield_mode
6614       eij=facont_hb(jj,i)
6615       ekl=facont_hb(kk,k)
6616       ees0pij=ees0p(jj,i)
6617       ees0pkl=ees0p(kk,k)
6618       ees0mij=ees0m(jj,i)
6619       ees0mkl=ees0m(kk,k)
6620       ekont=eij*ekl
6621       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6622 C*
6623 C     & fac_shield(i)**2*fac_shield(j)**2
6624 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6625 C Following 4 lines for diagnostics.
6626 cd    ees0pkl=0.0D0
6627 cd    ees0pij=1.0D0
6628 cd    ees0mkl=0.0D0
6629 cd    ees0mij=1.0D0
6630 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6631 c     & 'Contacts ',i,j,
6632 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6633 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6634 c     & 'gradcorr_long'
6635 C Calculate the multi-body contribution to energy.
6636 C      ecorr=ecorr+ekont*ees
6637 C Calculate multi-body contributions to the gradient.
6638       coeffpees0pij=coeffp*ees0pij
6639       coeffmees0mij=coeffm*ees0mij
6640       coeffpees0pkl=coeffp*ees0pkl
6641       coeffmees0mkl=coeffm*ees0mkl
6642       do ll=1,3
6643 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6644         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6645      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6646      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6647         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6648      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6649      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6650 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6651         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6652      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6653      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6654         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6655      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6656      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6657         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6658      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6659      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6660         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6661         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6662         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6663      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6664      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6665         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6666         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6667 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6668       enddo
6669 c      write (iout,*)
6670 cgrad      do m=i+1,j-1
6671 cgrad        do ll=1,3
6672 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6673 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6674 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6675 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6676 cgrad        enddo
6677 cgrad      enddo
6678 cgrad      do m=k+1,l-1
6679 cgrad        do ll=1,3
6680 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6681 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6682 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6683 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6684 cgrad        enddo
6685 cgrad      enddo
6686 c      write (iout,*) "ehbcorr",ekont*ees
6687 C      print *,ekont,ees,i,k
6688       ehbcorr=ekont*ees
6689 C now gradient over shielding
6690 C      return
6691       if (shield_mode.gt.0) then
6692        j=ees0plist(jj,i)
6693        l=ees0plist(kk,k)
6694 C        print *,i,j,fac_shield(i),fac_shield(j),
6695 C     &fac_shield(k),fac_shield(l)
6696         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6697      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6698           do ilist=1,ishield_list(i)
6699            iresshield=shield_list(ilist,i)
6700            do m=1,3
6701            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6702 C     &      *2.0
6703            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6704      &              rlocshield
6705      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6706             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6707      &+rlocshield
6708            enddo
6709           enddo
6710           do ilist=1,ishield_list(j)
6711            iresshield=shield_list(ilist,j)
6712            do m=1,3
6713            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6714 C     &     *2.0
6715            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6716      &              rlocshield
6717      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6718            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6719      &     +rlocshield
6720            enddo
6721           enddo
6722
6723           do ilist=1,ishield_list(k)
6724            iresshield=shield_list(ilist,k)
6725            do m=1,3
6726            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6727 C     &     *2.0
6728            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6729      &              rlocshield
6730      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6731            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6732      &     +rlocshield
6733            enddo
6734           enddo
6735           do ilist=1,ishield_list(l)
6736            iresshield=shield_list(ilist,l)
6737            do m=1,3
6738            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6739 C     &     *2.0
6740            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6741      &              rlocshield
6742      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6743            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6744      &     +rlocshield
6745            enddo
6746           enddo
6747 C          print *,gshieldx(m,iresshield)
6748           do m=1,3
6749             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6750      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6751             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6752      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6753             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6754      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6755             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6756      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6757
6758             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6759      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6760             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6761      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6762             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6763      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6764             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6765      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6766
6767            enddo
6768       endif
6769       endif
6770       return
6771       end
6772 #ifdef MOMENT
6773 C---------------------------------------------------------------------------
6774       subroutine dipole(i,j,jj)
6775       implicit real*8 (a-h,o-z)
6776       include 'DIMENSIONS'
6777       include 'COMMON.IOUNITS'
6778       include 'COMMON.CHAIN'
6779       include 'COMMON.FFIELD'
6780       include 'COMMON.DERIV'
6781       include 'COMMON.INTERACT'
6782       include 'COMMON.CONTACTS'
6783       include 'COMMON.TORSION'
6784       include 'COMMON.VAR'
6785       include 'COMMON.GEO'
6786       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6787      &  auxmat(2,2)
6788       iti1 = itortyp(itype(i+1))
6789       if (j.lt.nres-1) then
6790         itj1 = itype2loc(itype(j+1))
6791       else
6792         itj1=nloctyp
6793       endif
6794       do iii=1,2
6795         dipi(iii,1)=Ub2(iii,i)
6796         dipderi(iii)=Ub2der(iii,i)
6797         dipi(iii,2)=b1(iii,i+1)
6798         dipj(iii,1)=Ub2(iii,j)
6799         dipderj(iii)=Ub2der(iii,j)
6800         dipj(iii,2)=b1(iii,j+1)
6801       enddo
6802       kkk=0
6803       do iii=1,2
6804         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6805         do jjj=1,2
6806           kkk=kkk+1
6807           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6808         enddo
6809       enddo
6810       do kkk=1,5
6811         do lll=1,3
6812           mmm=0
6813           do iii=1,2
6814             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6815      &        auxvec(1))
6816             do jjj=1,2
6817               mmm=mmm+1
6818               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6819             enddo
6820           enddo
6821         enddo
6822       enddo
6823       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6824       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6825       do iii=1,2
6826         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6827       enddo
6828       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6829       do iii=1,2
6830         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6831       enddo
6832       return
6833       end
6834 #endif
6835 C---------------------------------------------------------------------------
6836       subroutine calc_eello(i,j,k,l,jj,kk)
6837 C
6838 C This subroutine computes matrices and vectors needed to calculate
6839 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6840 C
6841       implicit real*8 (a-h,o-z)
6842       include 'DIMENSIONS'
6843       include 'COMMON.IOUNITS'
6844       include 'COMMON.CHAIN'
6845       include 'COMMON.DERIV'
6846       include 'COMMON.INTERACT'
6847       include 'COMMON.CONTACTS'
6848       include 'COMMON.TORSION'
6849       include 'COMMON.VAR'
6850       include 'COMMON.GEO'
6851       include 'COMMON.FFIELD'
6852       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6853      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6854       logical lprn
6855       common /kutas/ lprn
6856 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6857 cd     & ' jj=',jj,' kk=',kk
6858 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6859 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6860 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6861       do iii=1,2
6862         do jjj=1,2
6863           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6864           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6865         enddo
6866       enddo
6867       call transpose2(aa1(1,1),aa1t(1,1))
6868       call transpose2(aa2(1,1),aa2t(1,1))
6869       do kkk=1,5
6870         do lll=1,3
6871           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6872      &      aa1tder(1,1,lll,kkk))
6873           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6874      &      aa2tder(1,1,lll,kkk))
6875         enddo
6876       enddo
6877       if (l.eq.j+1) then
6878 C parallel orientation of the two CA-CA-CA frames.
6879         if (i.gt.1) then
6880           iti=itype2loc(itype(i))
6881         else
6882           iti=nloctyp
6883         endif
6884         itk1=itype2loc(itype(k+1))
6885         itj=itype2loc(itype(j))
6886         if (l.lt.nres-1) then
6887           itl1=itype2loc(itype(l+1))
6888         else
6889           itl1=nloctyp
6890         endif
6891 C A1 kernel(j+1) A2T
6892 cd        do iii=1,2
6893 cd          write (iout,'(3f10.5,5x,3f10.5)')
6894 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6895 cd        enddo
6896         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6897      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6898      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6899 C Following matrices are needed only for 6-th order cumulants
6900         IF (wcorr6.gt.0.0d0) THEN
6901         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6902      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6903      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6904         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6905      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6906      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6907      &   ADtEAderx(1,1,1,1,1,1))
6908         lprn=.false.
6909         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6910      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6911      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6912      &   ADtEA1derx(1,1,1,1,1,1))
6913         ENDIF
6914 C End 6-th order cumulants
6915 cd        lprn=.false.
6916 cd        if (lprn) then
6917 cd        write (2,*) 'In calc_eello6'
6918 cd        do iii=1,2
6919 cd          write (2,*) 'iii=',iii
6920 cd          do kkk=1,5
6921 cd            write (2,*) 'kkk=',kkk
6922 cd            do jjj=1,2
6923 cd              write (2,'(3(2f10.5),5x)')
6924 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6925 cd            enddo
6926 cd          enddo
6927 cd        enddo
6928 cd        endif
6929         call transpose2(EUgder(1,1,k),auxmat(1,1))
6930         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6931         call transpose2(EUg(1,1,k),auxmat(1,1))
6932         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6933         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6934         do iii=1,2
6935           do kkk=1,5
6936             do lll=1,3
6937               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6938      &          EAEAderx(1,1,lll,kkk,iii,1))
6939             enddo
6940           enddo
6941         enddo
6942 C A1T kernel(i+1) A2
6943         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6944      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6945      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6946 C Following matrices are needed only for 6-th order cumulants
6947         IF (wcorr6.gt.0.0d0) THEN
6948         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6949      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6950      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6951         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6952      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6953      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6954      &   ADtEAderx(1,1,1,1,1,2))
6955         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6956      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6957      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6958      &   ADtEA1derx(1,1,1,1,1,2))
6959         ENDIF
6960 C End 6-th order cumulants
6961         call transpose2(EUgder(1,1,l),auxmat(1,1))
6962         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6963         call transpose2(EUg(1,1,l),auxmat(1,1))
6964         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6965         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6966         do iii=1,2
6967           do kkk=1,5
6968             do lll=1,3
6969               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6970      &          EAEAderx(1,1,lll,kkk,iii,2))
6971             enddo
6972           enddo
6973         enddo
6974 C AEAb1 and AEAb2
6975 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6976 C They are needed only when the fifth- or the sixth-order cumulants are
6977 C indluded.
6978         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6979         call transpose2(AEA(1,1,1),auxmat(1,1))
6980         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6981         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6982         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6983         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6984         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6985         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6986         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6987         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6988         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6989         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6990         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6991         call transpose2(AEA(1,1,2),auxmat(1,1))
6992         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6993         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6994         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6995         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6996         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6997         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6998         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6999         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7000         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7001         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7002         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7003 C Calculate the Cartesian derivatives of the vectors.
7004         do iii=1,2
7005           do kkk=1,5
7006             do lll=1,3
7007               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7008               call matvec2(auxmat(1,1),b1(1,i),
7009      &          AEAb1derx(1,lll,kkk,iii,1,1))
7010               call matvec2(auxmat(1,1),Ub2(1,i),
7011      &          AEAb2derx(1,lll,kkk,iii,1,1))
7012               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7013      &          AEAb1derx(1,lll,kkk,iii,2,1))
7014               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7015      &          AEAb2derx(1,lll,kkk,iii,2,1))
7016               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7017               call matvec2(auxmat(1,1),b1(1,j),
7018      &          AEAb1derx(1,lll,kkk,iii,1,2))
7019               call matvec2(auxmat(1,1),Ub2(1,j),
7020      &          AEAb2derx(1,lll,kkk,iii,1,2))
7021               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7022      &          AEAb1derx(1,lll,kkk,iii,2,2))
7023               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7024      &          AEAb2derx(1,lll,kkk,iii,2,2))
7025             enddo
7026           enddo
7027         enddo
7028         ENDIF
7029 C End vectors
7030       else
7031 C Antiparallel orientation of the two CA-CA-CA frames.
7032         if (i.gt.1) then
7033           iti=itype2loc(itype(i))
7034         else
7035           iti=nloctyp
7036         endif
7037         itk1=itype2loc(itype(k+1))
7038         itl=itype2loc(itype(l))
7039         itj=itype2loc(itype(j))
7040         if (j.lt.nres-1) then
7041           itj1=itype2loc(itype(j+1))
7042         else
7043           itj1=nloctyp
7044         endif
7045 C A2 kernel(j-1)T A1T
7046         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7047      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7048      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7049 C Following matrices are needed only for 6-th order cumulants
7050         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7051      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7052         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7053      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7054      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7055         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7056      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7057      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7058      &   ADtEAderx(1,1,1,1,1,1))
7059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7060      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7061      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7062      &   ADtEA1derx(1,1,1,1,1,1))
7063         ENDIF
7064 C End 6-th order cumulants
7065         call transpose2(EUgder(1,1,k),auxmat(1,1))
7066         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7067         call transpose2(EUg(1,1,k),auxmat(1,1))
7068         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7069         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7070         do iii=1,2
7071           do kkk=1,5
7072             do lll=1,3
7073               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7074      &          EAEAderx(1,1,lll,kkk,iii,1))
7075             enddo
7076           enddo
7077         enddo
7078 C A2T kernel(i+1)T A1
7079         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7080      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7081      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7082 C Following matrices are needed only for 6-th order cumulants
7083         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7084      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7085         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7086      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7087      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7088         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7089      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7090      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7091      &   ADtEAderx(1,1,1,1,1,2))
7092         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7093      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7094      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7095      &   ADtEA1derx(1,1,1,1,1,2))
7096         ENDIF
7097 C End 6-th order cumulants
7098         call transpose2(EUgder(1,1,j),auxmat(1,1))
7099         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7100         call transpose2(EUg(1,1,j),auxmat(1,1))
7101         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7102         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7103         do iii=1,2
7104           do kkk=1,5
7105             do lll=1,3
7106               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7107      &          EAEAderx(1,1,lll,kkk,iii,2))
7108             enddo
7109           enddo
7110         enddo
7111 C AEAb1 and AEAb2
7112 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7113 C They are needed only when the fifth- or the sixth-order cumulants are
7114 C indluded.
7115         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7116      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7117         call transpose2(AEA(1,1,1),auxmat(1,1))
7118         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7119         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7120         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7121         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7122         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7123         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7124         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7125         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7126         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7127         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7128         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7129         call transpose2(AEA(1,1,2),auxmat(1,1))
7130         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7131         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7132         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7133         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7134         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7135         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7136         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7137         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7138         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7139         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7140         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7141 C Calculate the Cartesian derivatives of the vectors.
7142         do iii=1,2
7143           do kkk=1,5
7144             do lll=1,3
7145               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7146               call matvec2(auxmat(1,1),b1(1,i),
7147      &          AEAb1derx(1,lll,kkk,iii,1,1))
7148               call matvec2(auxmat(1,1),Ub2(1,i),
7149      &          AEAb2derx(1,lll,kkk,iii,1,1))
7150               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7151      &          AEAb1derx(1,lll,kkk,iii,2,1))
7152               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7153      &          AEAb2derx(1,lll,kkk,iii,2,1))
7154               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7155               call matvec2(auxmat(1,1),b1(1,l),
7156      &          AEAb1derx(1,lll,kkk,iii,1,2))
7157               call matvec2(auxmat(1,1),Ub2(1,l),
7158      &          AEAb2derx(1,lll,kkk,iii,1,2))
7159               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7160      &          AEAb1derx(1,lll,kkk,iii,2,2))
7161               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7162      &          AEAb2derx(1,lll,kkk,iii,2,2))
7163             enddo
7164           enddo
7165         enddo
7166         ENDIF
7167 C End vectors
7168       endif
7169       return
7170       end
7171 C---------------------------------------------------------------------------
7172       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7173      &  KK,KKderg,AKA,AKAderg,AKAderx)
7174       implicit none
7175       integer nderg
7176       logical transp
7177       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7178      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7179      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7180       integer iii,kkk,lll
7181       integer jjj,mmm
7182       logical lprn
7183       common /kutas/ lprn
7184       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7185       do iii=1,nderg
7186         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7187      &    AKAderg(1,1,iii))
7188       enddo
7189 cd      if (lprn) write (2,*) 'In kernel'
7190       do kkk=1,5
7191 cd        if (lprn) write (2,*) 'kkk=',kkk
7192         do lll=1,3
7193           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7194      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7195 cd          if (lprn) then
7196 cd            write (2,*) 'lll=',lll
7197 cd            write (2,*) 'iii=1'
7198 cd            do jjj=1,2
7199 cd              write (2,'(3(2f10.5),5x)')
7200 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7201 cd            enddo
7202 cd          endif
7203           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7204      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7205 cd          if (lprn) then
7206 cd            write (2,*) 'lll=',lll
7207 cd            write (2,*) 'iii=2'
7208 cd            do jjj=1,2
7209 cd              write (2,'(3(2f10.5),5x)')
7210 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7211 cd            enddo
7212 cd          endif
7213         enddo
7214       enddo
7215       return
7216       end
7217 C---------------------------------------------------------------------------
7218       double precision function eello4(i,j,k,l,jj,kk)
7219       implicit real*8 (a-h,o-z)
7220       include 'DIMENSIONS'
7221       include 'COMMON.IOUNITS'
7222       include 'COMMON.CHAIN'
7223       include 'COMMON.DERIV'
7224       include 'COMMON.INTERACT'
7225       include 'COMMON.CONTACTS'
7226       include 'COMMON.TORSION'
7227       include 'COMMON.VAR'
7228       include 'COMMON.GEO'
7229       double precision pizda(2,2),ggg1(3),ggg2(3)
7230 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7231 cd        eello4=0.0d0
7232 cd        return
7233 cd      endif
7234 cd      print *,'eello4:',i,j,k,l,jj,kk
7235 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7236 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7237 cold      eij=facont_hb(jj,i)
7238 cold      ekl=facont_hb(kk,k)
7239 cold      ekont=eij*ekl
7240       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7241       if (calc_grad) then
7242 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7243       gcorr_loc(k-1)=gcorr_loc(k-1)
7244      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7245       if (l.eq.j+1) then
7246         gcorr_loc(l-1)=gcorr_loc(l-1)
7247      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7248       else
7249         gcorr_loc(j-1)=gcorr_loc(j-1)
7250      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7251       endif
7252       do iii=1,2
7253         do kkk=1,5
7254           do lll=1,3
7255             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7256      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7257 cd            derx(lll,kkk,iii)=0.0d0
7258           enddo
7259         enddo
7260       enddo
7261 cd      gcorr_loc(l-1)=0.0d0
7262 cd      gcorr_loc(j-1)=0.0d0
7263 cd      gcorr_loc(k-1)=0.0d0
7264 cd      eel4=1.0d0
7265 cd      write (iout,*)'Contacts have occurred for peptide groups',
7266 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7267 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7268       if (j.lt.nres-1) then
7269         j1=j+1
7270         j2=j-1
7271       else
7272         j1=j-1
7273         j2=j-2
7274       endif
7275       if (l.lt.nres-1) then
7276         l1=l+1
7277         l2=l-1
7278       else
7279         l1=l-1
7280         l2=l-2
7281       endif
7282       do ll=1,3
7283 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7284 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7285         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7286         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7287 cgrad        ghalf=0.5d0*ggg1(ll)
7288         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7289         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7290         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7291         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7292         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7293         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7294 cgrad        ghalf=0.5d0*ggg2(ll)
7295         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7296         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7297         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7298         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7299         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7300         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7301       enddo
7302 cgrad      do m=i+1,j-1
7303 cgrad        do ll=1,3
7304 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7305 cgrad        enddo
7306 cgrad      enddo
7307 cgrad      do m=k+1,l-1
7308 cgrad        do ll=1,3
7309 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7310 cgrad        enddo
7311 cgrad      enddo
7312 cgrad      do m=i+2,j2
7313 cgrad        do ll=1,3
7314 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7315 cgrad        enddo
7316 cgrad      enddo
7317 cgrad      do m=k+2,l2
7318 cgrad        do ll=1,3
7319 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7320 cgrad        enddo
7321 cgrad      enddo
7322 cd      do iii=1,nres-3
7323 cd        write (2,*) iii,gcorr_loc(iii)
7324 cd      enddo
7325       endif ! calc_grad
7326       eello4=ekont*eel4
7327 cd      write (2,*) 'ekont',ekont
7328 cd      write (iout,*) 'eello4',ekont*eel4
7329       return
7330       end
7331 C---------------------------------------------------------------------------
7332       double precision function eello5(i,j,k,l,jj,kk)
7333       implicit real*8 (a-h,o-z)
7334       include 'DIMENSIONS'
7335       include 'COMMON.IOUNITS'
7336       include 'COMMON.CHAIN'
7337       include 'COMMON.DERIV'
7338       include 'COMMON.INTERACT'
7339       include 'COMMON.CONTACTS'
7340       include 'COMMON.TORSION'
7341       include 'COMMON.VAR'
7342       include 'COMMON.GEO'
7343       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7344       double precision ggg1(3),ggg2(3)
7345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7346 C                                                                              C
7347 C                            Parallel chains                                   C
7348 C                                                                              C
7349 C          o             o                   o             o                   C
7350 C         /l\           / \             \   / \           / \   /              C
7351 C        /   \         /   \             \ /   \         /   \ /               C
7352 C       j| o |l1       | o |              o| o |         | o |o                C
7353 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7354 C      \i/   \         /   \ /             /   \         /   \                 C
7355 C       o    k1             o                                                  C
7356 C         (I)          (II)                (III)          (IV)                 C
7357 C                                                                              C
7358 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7359 C                                                                              C
7360 C                            Antiparallel chains                               C
7361 C                                                                              C
7362 C          o             o                   o             o                   C
7363 C         /j\           / \             \   / \           / \   /              C
7364 C        /   \         /   \             \ /   \         /   \ /               C
7365 C      j1| o |l        | o |              o| o |         | o |o                C
7366 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7367 C      \i/   \         /   \ /             /   \         /   \                 C
7368 C       o     k1            o                                                  C
7369 C         (I)          (II)                (III)          (IV)                 C
7370 C                                                                              C
7371 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7372 C                                                                              C
7373 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7374 C                                                                              C
7375 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7376 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7377 cd        eello5=0.0d0
7378 cd        return
7379 cd      endif
7380 cd      write (iout,*)
7381 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7382 cd     &   ' and',k,l
7383       itk=itype2loc(itype(k))
7384       itl=itype2loc(itype(l))
7385       itj=itype2loc(itype(j))
7386       eello5_1=0.0d0
7387       eello5_2=0.0d0
7388       eello5_3=0.0d0
7389       eello5_4=0.0d0
7390 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7391 cd     &   eel5_3_num,eel5_4_num)
7392       do iii=1,2
7393         do kkk=1,5
7394           do lll=1,3
7395             derx(lll,kkk,iii)=0.0d0
7396           enddo
7397         enddo
7398       enddo
7399 cd      eij=facont_hb(jj,i)
7400 cd      ekl=facont_hb(kk,k)
7401 cd      ekont=eij*ekl
7402 cd      write (iout,*)'Contacts have occurred for peptide groups',
7403 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7404 cd      goto 1111
7405 C Contribution from the graph I.
7406 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7407 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7408       call transpose2(EUg(1,1,k),auxmat(1,1))
7409       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7410       vv(1)=pizda(1,1)-pizda(2,2)
7411       vv(2)=pizda(1,2)+pizda(2,1)
7412       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7413      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7414       if (calc_grad) then
7415 C Explicit gradient in virtual-dihedral angles.
7416       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7417      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7418      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7419       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7420       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7421       vv(1)=pizda(1,1)-pizda(2,2)
7422       vv(2)=pizda(1,2)+pizda(2,1)
7423       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7424      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7425      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7426       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7427       vv(1)=pizda(1,1)-pizda(2,2)
7428       vv(2)=pizda(1,2)+pizda(2,1)
7429       if (l.eq.j+1) then
7430         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7431      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7432      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7433       else
7434         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7435      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7436      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7437       endif
7438 C Cartesian gradient
7439       do iii=1,2
7440         do kkk=1,5
7441           do lll=1,3
7442             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7443      &        pizda(1,1))
7444             vv(1)=pizda(1,1)-pizda(2,2)
7445             vv(2)=pizda(1,2)+pizda(2,1)
7446             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7447      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7448      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7449           enddo
7450         enddo
7451       enddo
7452       endif ! calc_grad
7453 c      goto 1112
7454 c1111  continue
7455 C Contribution from graph II
7456       call transpose2(EE(1,1,k),auxmat(1,1))
7457       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7458       vv(1)=pizda(1,1)+pizda(2,2)
7459       vv(2)=pizda(2,1)-pizda(1,2)
7460       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7461      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7462       if (calc_grad) then
7463 C Explicit gradient in virtual-dihedral angles.
7464       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7465      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7466       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7467       vv(1)=pizda(1,1)+pizda(2,2)
7468       vv(2)=pizda(2,1)-pizda(1,2)
7469       if (l.eq.j+1) then
7470         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7471      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7472      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7473       else
7474         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7475      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7476      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7477       endif
7478 C Cartesian gradient
7479       do iii=1,2
7480         do kkk=1,5
7481           do lll=1,3
7482             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7483      &        pizda(1,1))
7484             vv(1)=pizda(1,1)+pizda(2,2)
7485             vv(2)=pizda(2,1)-pizda(1,2)
7486             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7487      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7488      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7489           enddo
7490         enddo
7491       enddo
7492       endif ! calc_grad
7493 cd      goto 1112
7494 cd1111  continue
7495       if (l.eq.j+1) then
7496 cd        goto 1110
7497 C Parallel orientation
7498 C Contribution from graph III
7499         call transpose2(EUg(1,1,l),auxmat(1,1))
7500         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7501         vv(1)=pizda(1,1)-pizda(2,2)
7502         vv(2)=pizda(1,2)+pizda(2,1)
7503         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7504      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7505         if (calc_grad) then
7506 C Explicit gradient in virtual-dihedral angles.
7507         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7508      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7509      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7510         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7511         vv(1)=pizda(1,1)-pizda(2,2)
7512         vv(2)=pizda(1,2)+pizda(2,1)
7513         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7514      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7515      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7516         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7517         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7518         vv(1)=pizda(1,1)-pizda(2,2)
7519         vv(2)=pizda(1,2)+pizda(2,1)
7520         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7521      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7522      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7523 C Cartesian gradient
7524         do iii=1,2
7525           do kkk=1,5
7526             do lll=1,3
7527               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7528      &          pizda(1,1))
7529               vv(1)=pizda(1,1)-pizda(2,2)
7530               vv(2)=pizda(1,2)+pizda(2,1)
7531               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7532      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7533      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7534             enddo
7535           enddo
7536         enddo
7537 cd        goto 1112
7538 C Contribution from graph IV
7539 cd1110    continue
7540         call transpose2(EE(1,1,l),auxmat(1,1))
7541         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7542         vv(1)=pizda(1,1)+pizda(2,2)
7543         vv(2)=pizda(2,1)-pizda(1,2)
7544         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7545      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7546 C Explicit gradient in virtual-dihedral angles.
7547         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7548      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7549         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7550         vv(1)=pizda(1,1)+pizda(2,2)
7551         vv(2)=pizda(2,1)-pizda(1,2)
7552         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7553      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7554      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7555 C Cartesian gradient
7556         do iii=1,2
7557           do kkk=1,5
7558             do lll=1,3
7559               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7560      &          pizda(1,1))
7561               vv(1)=pizda(1,1)+pizda(2,2)
7562               vv(2)=pizda(2,1)-pizda(1,2)
7563               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7564      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7565      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7566             enddo
7567           enddo
7568         enddo
7569         endif ! calc_grad
7570       else
7571 C Antiparallel orientation
7572 C Contribution from graph III
7573 c        goto 1110
7574         call transpose2(EUg(1,1,j),auxmat(1,1))
7575         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7576         vv(1)=pizda(1,1)-pizda(2,2)
7577         vv(2)=pizda(1,2)+pizda(2,1)
7578         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7579      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7580         if (calc_grad) then
7581 C Explicit gradient in virtual-dihedral angles.
7582         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7583      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7584      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7585         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7586         vv(1)=pizda(1,1)-pizda(2,2)
7587         vv(2)=pizda(1,2)+pizda(2,1)
7588         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7589      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7591         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7592         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7593         vv(1)=pizda(1,1)-pizda(2,2)
7594         vv(2)=pizda(1,2)+pizda(2,1)
7595         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7596      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7597      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7598 C Cartesian gradient
7599         do iii=1,2
7600           do kkk=1,5
7601             do lll=1,3
7602               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7603      &          pizda(1,1))
7604               vv(1)=pizda(1,1)-pizda(2,2)
7605               vv(2)=pizda(1,2)+pizda(2,1)
7606               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7607      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7608      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7609             enddo
7610           enddo
7611         enddo
7612         endif ! calc_grad
7613 cd        goto 1112
7614 C Contribution from graph IV
7615 1110    continue
7616         call transpose2(EE(1,1,j),auxmat(1,1))
7617         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7618         vv(1)=pizda(1,1)+pizda(2,2)
7619         vv(2)=pizda(2,1)-pizda(1,2)
7620         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7621      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7622         if (calc_grad) then
7623 C Explicit gradient in virtual-dihedral angles.
7624         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7625      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7626         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7627         vv(1)=pizda(1,1)+pizda(2,2)
7628         vv(2)=pizda(2,1)-pizda(1,2)
7629         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7630      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7631      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7632 C Cartesian gradient
7633         do iii=1,2
7634           do kkk=1,5
7635             do lll=1,3
7636               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7637      &          pizda(1,1))
7638               vv(1)=pizda(1,1)+pizda(2,2)
7639               vv(2)=pizda(2,1)-pizda(1,2)
7640               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7641      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7642      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7643             enddo
7644           enddo
7645         enddo
7646         endif ! calc_grad
7647       endif
7648 1112  continue
7649       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7650 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7651 cd        write (2,*) 'ijkl',i,j,k,l
7652 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7653 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7654 cd      endif
7655 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7656 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7657 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7658 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7659       if (calc_grad) then
7660       if (j.lt.nres-1) then
7661         j1=j+1
7662         j2=j-1
7663       else
7664         j1=j-1
7665         j2=j-2
7666       endif
7667       if (l.lt.nres-1) then
7668         l1=l+1
7669         l2=l-1
7670       else
7671         l1=l-1
7672         l2=l-2
7673       endif
7674 cd      eij=1.0d0
7675 cd      ekl=1.0d0
7676 cd      ekont=1.0d0
7677 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7678 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7679 C        summed up outside the subrouine as for the other subroutines
7680 C        handling long-range interactions. The old code is commented out
7681 C        with "cgrad" to keep track of changes.
7682       do ll=1,3
7683 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7684 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7685         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7686         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7687 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7688 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7689 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7690 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7691 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7692 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7693 c     &   gradcorr5ij,
7694 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7695 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7696 cgrad        ghalf=0.5d0*ggg1(ll)
7697 cd        ghalf=0.0d0
7698         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7699         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7700         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7701         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7702         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7703         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7704 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7705 cgrad        ghalf=0.5d0*ggg2(ll)
7706 cd        ghalf=0.0d0
7707         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7708         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7709         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7710         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7711         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7712         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7713       enddo
7714       endif ! calc_grad
7715 cd      goto 1112
7716 cgrad      do m=i+1,j-1
7717 cgrad        do ll=1,3
7718 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7719 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7720 cgrad        enddo
7721 cgrad      enddo
7722 cgrad      do m=k+1,l-1
7723 cgrad        do ll=1,3
7724 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7725 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7726 cgrad        enddo
7727 cgrad      enddo
7728 c1112  continue
7729 cgrad      do m=i+2,j2
7730 cgrad        do ll=1,3
7731 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7732 cgrad        enddo
7733 cgrad      enddo
7734 cgrad      do m=k+2,l2
7735 cgrad        do ll=1,3
7736 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7737 cgrad        enddo
7738 cgrad      enddo
7739 cd      do iii=1,nres-3
7740 cd        write (2,*) iii,g_corr5_loc(iii)
7741 cd      enddo
7742       eello5=ekont*eel5
7743 cd      write (2,*) 'ekont',ekont
7744 cd      write (iout,*) 'eello5',ekont*eel5
7745       return
7746       end
7747 c--------------------------------------------------------------------------
7748       double precision function eello6(i,j,k,l,jj,kk)
7749       implicit real*8 (a-h,o-z)
7750       include 'DIMENSIONS'
7751       include 'COMMON.IOUNITS'
7752       include 'COMMON.CHAIN'
7753       include 'COMMON.DERIV'
7754       include 'COMMON.INTERACT'
7755       include 'COMMON.CONTACTS'
7756       include 'COMMON.TORSION'
7757       include 'COMMON.VAR'
7758       include 'COMMON.GEO'
7759       include 'COMMON.FFIELD'
7760       double precision ggg1(3),ggg2(3)
7761 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7762 cd        eello6=0.0d0
7763 cd        return
7764 cd      endif
7765 cd      write (iout,*)
7766 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7767 cd     &   ' and',k,l
7768       eello6_1=0.0d0
7769       eello6_2=0.0d0
7770       eello6_3=0.0d0
7771       eello6_4=0.0d0
7772       eello6_5=0.0d0
7773       eello6_6=0.0d0
7774 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7775 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7776       do iii=1,2
7777         do kkk=1,5
7778           do lll=1,3
7779             derx(lll,kkk,iii)=0.0d0
7780           enddo
7781         enddo
7782       enddo
7783 cd      eij=facont_hb(jj,i)
7784 cd      ekl=facont_hb(kk,k)
7785 cd      ekont=eij*ekl
7786 cd      eij=1.0d0
7787 cd      ekl=1.0d0
7788 cd      ekont=1.0d0
7789       if (l.eq.j+1) then
7790         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7791         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7792         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7793         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7794         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7795         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7796       else
7797         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7798         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7799         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7800         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7801         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7802           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7803         else
7804           eello6_5=0.0d0
7805         endif
7806         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7807       endif
7808 C If turn contributions are considered, they will be handled separately.
7809       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7810 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7811 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7812 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7813 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7814 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7815 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7816 cd      goto 1112
7817       if (calc_grad) then
7818       if (j.lt.nres-1) then
7819         j1=j+1
7820         j2=j-1
7821       else
7822         j1=j-1
7823         j2=j-2
7824       endif
7825       if (l.lt.nres-1) then
7826         l1=l+1
7827         l2=l-1
7828       else
7829         l1=l-1
7830         l2=l-2
7831       endif
7832       do ll=1,3
7833 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7834 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7835 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7836 cgrad        ghalf=0.5d0*ggg1(ll)
7837 cd        ghalf=0.0d0
7838         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7839         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7840         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7841         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7842         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7843         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7844         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7845         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7846 cgrad        ghalf=0.5d0*ggg2(ll)
7847 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7848 cd        ghalf=0.0d0
7849         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7850         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7851         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7852         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7853         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7854         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7855       enddo
7856       endif ! calc_grad
7857 cd      goto 1112
7858 cgrad      do m=i+1,j-1
7859 cgrad        do ll=1,3
7860 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7861 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad      do m=k+1,l-1
7865 cgrad        do ll=1,3
7866 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad1112  continue
7871 cgrad      do m=i+2,j2
7872 cgrad        do ll=1,3
7873 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7874 cgrad        enddo
7875 cgrad      enddo
7876 cgrad      do m=k+2,l2
7877 cgrad        do ll=1,3
7878 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7879 cgrad        enddo
7880 cgrad      enddo
7881 cd      do iii=1,nres-3
7882 cd        write (2,*) iii,g_corr6_loc(iii)
7883 cd      enddo
7884       eello6=ekont*eel6
7885 cd      write (2,*) 'ekont',ekont
7886 cd      write (iout,*) 'eello6',ekont*eel6
7887       return
7888       end
7889 c--------------------------------------------------------------------------
7890       double precision function eello6_graph1(i,j,k,l,imat,swap)
7891       implicit real*8 (a-h,o-z)
7892       include 'DIMENSIONS'
7893       include 'COMMON.IOUNITS'
7894       include 'COMMON.CHAIN'
7895       include 'COMMON.DERIV'
7896       include 'COMMON.INTERACT'
7897       include 'COMMON.CONTACTS'
7898       include 'COMMON.TORSION'
7899       include 'COMMON.VAR'
7900       include 'COMMON.GEO'
7901       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7902       logical swap
7903       logical lprn
7904       common /kutas/ lprn
7905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7906 C                                                                              C
7907 C      Parallel       Antiparallel                                             C
7908 C                                                                              C
7909 C          o             o                                                     C
7910 C         /l\           /j\                                                    C
7911 C        /   \         /   \                                                   C
7912 C       /| o |         | o |\                                                  C
7913 C     \ j|/k\|  /   \  |/k\|l /                                                C
7914 C      \ /   \ /     \ /   \ /                                                 C
7915 C       o     o       o     o                                                  C
7916 C       i             i                                                        C
7917 C                                                                              C
7918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7919       itk=itype2loc(itype(k))
7920       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7921       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7922       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7923       call transpose2(EUgC(1,1,k),auxmat(1,1))
7924       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7925       vv1(1)=pizda1(1,1)-pizda1(2,2)
7926       vv1(2)=pizda1(1,2)+pizda1(2,1)
7927       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7928       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7929       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7930       s5=scalar2(vv(1),Dtobr2(1,i))
7931 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7932       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7933       if (calc_grad) then
7934       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7935      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7936      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7937      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7938      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7939      & +scalar2(vv(1),Dtobr2der(1,i)))
7940       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7941       vv1(1)=pizda1(1,1)-pizda1(2,2)
7942       vv1(2)=pizda1(1,2)+pizda1(2,1)
7943       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7944       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7945       if (l.eq.j+1) then
7946         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7947      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7948      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7949      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7950      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7951       else
7952         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7953      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7954      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7955      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7956      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7957       endif
7958       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7959       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7960       vv1(1)=pizda1(1,1)-pizda1(2,2)
7961       vv1(2)=pizda1(1,2)+pizda1(2,1)
7962       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7963      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7964      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7965      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7966       do iii=1,2
7967         if (swap) then
7968           ind=3-iii
7969         else
7970           ind=iii
7971         endif
7972         do kkk=1,5
7973           do lll=1,3
7974             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7975             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7976             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7977             call transpose2(EUgC(1,1,k),auxmat(1,1))
7978             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7979      &        pizda1(1,1))
7980             vv1(1)=pizda1(1,1)-pizda1(2,2)
7981             vv1(2)=pizda1(1,2)+pizda1(2,1)
7982             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7983             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7984      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7985             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7986      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7987             s5=scalar2(vv(1),Dtobr2(1,i))
7988             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7989           enddo
7990         enddo
7991       enddo
7992       endif ! calc_grad
7993       return
7994       end
7995 c----------------------------------------------------------------------------
7996       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7997       implicit real*8 (a-h,o-z)
7998       include 'DIMENSIONS'
7999       include 'COMMON.IOUNITS'
8000       include 'COMMON.CHAIN'
8001       include 'COMMON.DERIV'
8002       include 'COMMON.INTERACT'
8003       include 'COMMON.CONTACTS'
8004       include 'COMMON.TORSION'
8005       include 'COMMON.VAR'
8006       include 'COMMON.GEO'
8007       logical swap
8008       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8009      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8010       logical lprn
8011       common /kutas/ lprn
8012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8013 C                                                                              C
8014 C      Parallel       Antiparallel                                             C
8015 C                                                                              C
8016 C          o             o                                                     C
8017 C     \   /l\           /j\   /                                                C
8018 C      \ /   \         /   \ /                                                 C
8019 C       o| o |         | o |o                                                  C
8020 C     \ j|/k\|      \  |/k\|l                                                  C
8021 C      \ /   \       \ /   \                                                   C
8022 C       o             o                                                        C
8023 C       i             i                                                        C
8024 C                                                                              C
8025 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8026 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8027 C AL 7/4/01 s1 would occur in the sixth-order moment,
8028 C           but not in a cluster cumulant
8029 #ifdef MOMENT
8030       s1=dip(1,jj,i)*dip(1,kk,k)
8031 #endif
8032       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8033       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8034       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8035       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8036       call transpose2(EUg(1,1,k),auxmat(1,1))
8037       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8038       vv(1)=pizda(1,1)-pizda(2,2)
8039       vv(2)=pizda(1,2)+pizda(2,1)
8040       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8041 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8042 #ifdef MOMENT
8043       eello6_graph2=-(s1+s2+s3+s4)
8044 #else
8045       eello6_graph2=-(s2+s3+s4)
8046 #endif
8047 c      eello6_graph2=-s3
8048 C Derivatives in gamma(i-1)
8049       if (calc_grad) then
8050       if (i.gt.1) then
8051 #ifdef MOMENT
8052         s1=dipderg(1,jj,i)*dip(1,kk,k)
8053 #endif
8054         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8055         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8056         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8057         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8058 #ifdef MOMENT
8059         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8060 #else
8061         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8062 #endif
8063 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8064       endif
8065 C Derivatives in gamma(k-1)
8066 #ifdef MOMENT
8067       s1=dip(1,jj,i)*dipderg(1,kk,k)
8068 #endif
8069       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8070       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8071       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8072       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8073       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8074       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8075       vv(1)=pizda(1,1)-pizda(2,2)
8076       vv(2)=pizda(1,2)+pizda(2,1)
8077       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8078 #ifdef MOMENT
8079       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8080 #else
8081       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8082 #endif
8083 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8084 C Derivatives in gamma(j-1) or gamma(l-1)
8085       if (j.gt.1) then
8086 #ifdef MOMENT
8087         s1=dipderg(3,jj,i)*dip(1,kk,k)
8088 #endif
8089         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8090         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8091         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8092         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8093         vv(1)=pizda(1,1)-pizda(2,2)
8094         vv(2)=pizda(1,2)+pizda(2,1)
8095         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8096 #ifdef MOMENT
8097         if (swap) then
8098           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8099         else
8100           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8101         endif
8102 #endif
8103         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8104 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8105       endif
8106 C Derivatives in gamma(l-1) or gamma(j-1)
8107       if (l.gt.1) then
8108 #ifdef MOMENT
8109         s1=dip(1,jj,i)*dipderg(3,kk,k)
8110 #endif
8111         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8112         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8113         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8114         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8115         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8116         vv(1)=pizda(1,1)-pizda(2,2)
8117         vv(2)=pizda(1,2)+pizda(2,1)
8118         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8119 #ifdef MOMENT
8120         if (swap) then
8121           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8122         else
8123           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8124         endif
8125 #endif
8126         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8127 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8128       endif
8129 C Cartesian derivatives.
8130       if (lprn) then
8131         write (2,*) 'In eello6_graph2'
8132         do iii=1,2
8133           write (2,*) 'iii=',iii
8134           do kkk=1,5
8135             write (2,*) 'kkk=',kkk
8136             do jjj=1,2
8137               write (2,'(3(2f10.5),5x)')
8138      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8139             enddo
8140           enddo
8141         enddo
8142       endif
8143       do iii=1,2
8144         do kkk=1,5
8145           do lll=1,3
8146 #ifdef MOMENT
8147             if (iii.eq.1) then
8148               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8149             else
8150               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8151             endif
8152 #endif
8153             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8154      &        auxvec(1))
8155             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8156             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8157      &        auxvec(1))
8158             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8159             call transpose2(EUg(1,1,k),auxmat(1,1))
8160             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8161      &        pizda(1,1))
8162             vv(1)=pizda(1,1)-pizda(2,2)
8163             vv(2)=pizda(1,2)+pizda(2,1)
8164             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8165 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8166 #ifdef MOMENT
8167             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8168 #else
8169             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8170 #endif
8171             if (swap) then
8172               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8173             else
8174               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8175             endif
8176           enddo
8177         enddo
8178       enddo
8179       endif ! calc_grad
8180       return
8181       end
8182 c----------------------------------------------------------------------------
8183       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8184       implicit real*8 (a-h,o-z)
8185       include 'DIMENSIONS'
8186       include 'COMMON.IOUNITS'
8187       include 'COMMON.CHAIN'
8188       include 'COMMON.DERIV'
8189       include 'COMMON.INTERACT'
8190       include 'COMMON.CONTACTS'
8191       include 'COMMON.TORSION'
8192       include 'COMMON.VAR'
8193       include 'COMMON.GEO'
8194       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8195       logical swap
8196 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8197 C                                                                              C
8198 C      Parallel       Antiparallel                                             C
8199 C                                                                              C
8200 C          o             o                                                     C
8201 C         /l\   /   \   /j\                                                    C
8202 C        /   \ /     \ /   \                                                   C
8203 C       /| o |o       o| o |\                                                  C
8204 C       j|/k\|  /      |/k\|l /                                                C
8205 C        /   \ /       /   \ /                                                 C
8206 C       /     o       /     o                                                  C
8207 C       i             i                                                        C
8208 C                                                                              C
8209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8210 C
8211 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8212 C           energy moment and not to the cluster cumulant.
8213       iti=itortyp(itype(i))
8214       if (j.lt.nres-1) then
8215         itj1=itype2loc(itype(j+1))
8216       else
8217         itj1=nloctyp
8218       endif
8219       itk=itype2loc(itype(k))
8220       itk1=itype2loc(itype(k+1))
8221       if (l.lt.nres-1) then
8222         itl1=itype2loc(itype(l+1))
8223       else
8224         itl1=nloctyp
8225       endif
8226 #ifdef MOMENT
8227       s1=dip(4,jj,i)*dip(4,kk,k)
8228 #endif
8229       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8230       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8231       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8232       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8233       call transpose2(EE(1,1,k),auxmat(1,1))
8234       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8235       vv(1)=pizda(1,1)+pizda(2,2)
8236       vv(2)=pizda(2,1)-pizda(1,2)
8237       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8238 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8239 cd     & "sum",-(s2+s3+s4)
8240 #ifdef MOMENT
8241       eello6_graph3=-(s1+s2+s3+s4)
8242 #else
8243       eello6_graph3=-(s2+s3+s4)
8244 #endif
8245 c      eello6_graph3=-s4
8246 C Derivatives in gamma(k-1)
8247       if (calc_grad) then
8248       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8249       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8250       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8251       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8252 C Derivatives in gamma(l-1)
8253       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8254       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8255       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8256       vv(1)=pizda(1,1)+pizda(2,2)
8257       vv(2)=pizda(2,1)-pizda(1,2)
8258       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8259       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8260 C Cartesian derivatives.
8261       do iii=1,2
8262         do kkk=1,5
8263           do lll=1,3
8264 #ifdef MOMENT
8265             if (iii.eq.1) then
8266               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8267             else
8268               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8269             endif
8270 #endif
8271             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8272      &        auxvec(1))
8273             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8274             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8275      &        auxvec(1))
8276             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8277             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8278      &        pizda(1,1))
8279             vv(1)=pizda(1,1)+pizda(2,2)
8280             vv(2)=pizda(2,1)-pizda(1,2)
8281             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8282 #ifdef MOMENT
8283             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8284 #else
8285             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8286 #endif
8287             if (swap) then
8288               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8289             else
8290               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8291             endif
8292 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8293           enddo
8294         enddo
8295       enddo
8296       endif ! calc_grad
8297       return
8298       end
8299 c----------------------------------------------------------------------------
8300       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8301       implicit real*8 (a-h,o-z)
8302       include 'DIMENSIONS'
8303       include 'COMMON.IOUNITS'
8304       include 'COMMON.CHAIN'
8305       include 'COMMON.DERIV'
8306       include 'COMMON.INTERACT'
8307       include 'COMMON.CONTACTS'
8308       include 'COMMON.TORSION'
8309       include 'COMMON.VAR'
8310       include 'COMMON.GEO'
8311       include 'COMMON.FFIELD'
8312       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8313      & auxvec1(2),auxmat1(2,2)
8314       logical swap
8315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8316 C                                                                              C
8317 C      Parallel       Antiparallel                                             C
8318 C                                                                              C
8319 C          o             o                                                     C
8320 C         /l\   /   \   /j\                                                    C
8321 C        /   \ /     \ /   \                                                   C
8322 C       /| o |o       o| o |\                                                  C
8323 C     \ j|/k\|      \  |/k\|l                                                  C
8324 C      \ /   \       \ /   \                                                   C
8325 C       o     \       o     \                                                  C
8326 C       i             i                                                        C
8327 C                                                                              C
8328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8329 C
8330 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8331 C           energy moment and not to the cluster cumulant.
8332 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8333       iti=itype2loc(itype(i))
8334       itj=itype2loc(itype(j))
8335       if (j.lt.nres-1) then
8336         itj1=itype2loc(itype(j+1))
8337       else
8338         itj1=nloctyp
8339       endif
8340       itk=itype2loc(itype(k))
8341       if (k.lt.nres-1) then
8342         itk1=itype2loc(itype(k+1))
8343       else
8344         itk1=nloctyp
8345       endif
8346       itl=itype2loc(itype(l))
8347       if (l.lt.nres-1) then
8348         itl1=itype2loc(itype(l+1))
8349       else
8350         itl1=nloctyp
8351       endif
8352 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8353 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8354 cd     & ' itl',itl,' itl1',itl1
8355 #ifdef MOMENT
8356       if (imat.eq.1) then
8357         s1=dip(3,jj,i)*dip(3,kk,k)
8358       else
8359         s1=dip(2,jj,j)*dip(2,kk,l)
8360       endif
8361 #endif
8362       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8363       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8364       if (j.eq.l+1) then
8365         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8366         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8367       else
8368         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8369         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8370       endif
8371       call transpose2(EUg(1,1,k),auxmat(1,1))
8372       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8373       vv(1)=pizda(1,1)-pizda(2,2)
8374       vv(2)=pizda(2,1)+pizda(1,2)
8375       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8376 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8377 #ifdef MOMENT
8378       eello6_graph4=-(s1+s2+s3+s4)
8379 #else
8380       eello6_graph4=-(s2+s3+s4)
8381 #endif
8382 C Derivatives in gamma(i-1)
8383       if (calc_grad) then
8384       if (i.gt.1) then
8385 #ifdef MOMENT
8386         if (imat.eq.1) then
8387           s1=dipderg(2,jj,i)*dip(3,kk,k)
8388         else
8389           s1=dipderg(4,jj,j)*dip(2,kk,l)
8390         endif
8391 #endif
8392         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8393         if (j.eq.l+1) then
8394           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8395           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8396         else
8397           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8398           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8399         endif
8400         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8401         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8402 cd          write (2,*) 'turn6 derivatives'
8403 #ifdef MOMENT
8404           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8405 #else
8406           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8407 #endif
8408         else
8409 #ifdef MOMENT
8410           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8411 #else
8412           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8413 #endif
8414         endif
8415       endif
8416 C Derivatives in gamma(k-1)
8417 #ifdef MOMENT
8418       if (imat.eq.1) then
8419         s1=dip(3,jj,i)*dipderg(2,kk,k)
8420       else
8421         s1=dip(2,jj,j)*dipderg(4,kk,l)
8422       endif
8423 #endif
8424       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8425       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8426       if (j.eq.l+1) then
8427         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8428         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8429       else
8430         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8431         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8432       endif
8433       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8434       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8435       vv(1)=pizda(1,1)-pizda(2,2)
8436       vv(2)=pizda(2,1)+pizda(1,2)
8437       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8438       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8439 #ifdef MOMENT
8440         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8441 #else
8442         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8443 #endif
8444       else
8445 #ifdef MOMENT
8446         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8447 #else
8448         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8449 #endif
8450       endif
8451 C Derivatives in gamma(j-1) or gamma(l-1)
8452       if (l.eq.j+1 .and. l.gt.1) then
8453         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8454         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8455         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8456         vv(1)=pizda(1,1)-pizda(2,2)
8457         vv(2)=pizda(2,1)+pizda(1,2)
8458         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8459         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8460       else if (j.gt.1) then
8461         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8462         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8463         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8464         vv(1)=pizda(1,1)-pizda(2,2)
8465         vv(2)=pizda(2,1)+pizda(1,2)
8466         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8467         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8468           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8469         else
8470           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8471         endif
8472       endif
8473 C Cartesian derivatives.
8474       do iii=1,2
8475         do kkk=1,5
8476           do lll=1,3
8477 #ifdef MOMENT
8478             if (iii.eq.1) then
8479               if (imat.eq.1) then
8480                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8481               else
8482                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8483               endif
8484             else
8485               if (imat.eq.1) then
8486                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8487               else
8488                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8489               endif
8490             endif
8491 #endif
8492             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8493      &        auxvec(1))
8494             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8495             if (j.eq.l+1) then
8496               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8497      &          b1(1,j+1),auxvec(1))
8498               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8499             else
8500               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8501      &          b1(1,l+1),auxvec(1))
8502               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8503             endif
8504             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8505      &        pizda(1,1))
8506             vv(1)=pizda(1,1)-pizda(2,2)
8507             vv(2)=pizda(2,1)+pizda(1,2)
8508             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8509             if (swap) then
8510               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8511 #ifdef MOMENT
8512                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8513      &             -(s1+s2+s4)
8514 #else
8515                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8516      &             -(s2+s4)
8517 #endif
8518                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8519               else
8520 #ifdef MOMENT
8521                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8522 #else
8523                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8524 #endif
8525                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8526               endif
8527             else
8528 #ifdef MOMENT
8529               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8530 #else
8531               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8532 #endif
8533               if (l.eq.j+1) then
8534                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8535               else
8536                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8537               endif
8538             endif
8539           enddo
8540         enddo
8541       enddo
8542       endif ! calc_grad
8543       return
8544       end
8545 c----------------------------------------------------------------------------
8546       double precision function eello_turn6(i,jj,kk)
8547       implicit real*8 (a-h,o-z)
8548       include 'DIMENSIONS'
8549       include 'COMMON.IOUNITS'
8550       include 'COMMON.CHAIN'
8551       include 'COMMON.DERIV'
8552       include 'COMMON.INTERACT'
8553       include 'COMMON.CONTACTS'
8554       include 'COMMON.TORSION'
8555       include 'COMMON.VAR'
8556       include 'COMMON.GEO'
8557       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8558      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8559      &  ggg1(3),ggg2(3)
8560       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8561      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8562 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8563 C           the respective energy moment and not to the cluster cumulant.
8564       s1=0.0d0
8565       s8=0.0d0
8566       s13=0.0d0
8567 c
8568       eello_turn6=0.0d0
8569       j=i+4
8570       k=i+1
8571       l=i+3
8572       iti=itype2loc(itype(i))
8573       itk=itype2loc(itype(k))
8574       itk1=itype2loc(itype(k+1))
8575       itl=itype2loc(itype(l))
8576       itj=itype2loc(itype(j))
8577 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8578 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8579 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8580 cd        eello6=0.0d0
8581 cd        return
8582 cd      endif
8583 cd      write (iout,*)
8584 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8585 cd     &   ' and',k,l
8586 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8587       do iii=1,2
8588         do kkk=1,5
8589           do lll=1,3
8590             derx_turn(lll,kkk,iii)=0.0d0
8591           enddo
8592         enddo
8593       enddo
8594 cd      eij=1.0d0
8595 cd      ekl=1.0d0
8596 cd      ekont=1.0d0
8597       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8598 cd      eello6_5=0.0d0
8599 cd      write (2,*) 'eello6_5',eello6_5
8600 #ifdef MOMENT
8601       call transpose2(AEA(1,1,1),auxmat(1,1))
8602       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8603       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8604       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8605 #endif
8606       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8607       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8608       s2 = scalar2(b1(1,k),vtemp1(1))
8609 #ifdef MOMENT
8610       call transpose2(AEA(1,1,2),atemp(1,1))
8611       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8612       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8613       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8614 #endif
8615       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8616       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8617       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8618 #ifdef MOMENT
8619       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8620       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8621       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8622       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8623       ss13 = scalar2(b1(1,k),vtemp4(1))
8624       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8625 #endif
8626 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8627 c      s1=0.0d0
8628 c      s2=0.0d0
8629 c      s8=0.0d0
8630 c      s12=0.0d0
8631 c      s13=0.0d0
8632       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8633 C Derivatives in gamma(i+2)
8634       if (calc_grad) then
8635       s1d =0.0d0
8636       s8d =0.0d0
8637 #ifdef MOMENT
8638       call transpose2(AEA(1,1,1),auxmatd(1,1))
8639       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8640       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8641       call transpose2(AEAderg(1,1,2),atempd(1,1))
8642       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8643       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8644 #endif
8645       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8646       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8647       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8648 c      s1d=0.0d0
8649 c      s2d=0.0d0
8650 c      s8d=0.0d0
8651 c      s12d=0.0d0
8652 c      s13d=0.0d0
8653       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8654 C Derivatives in gamma(i+3)
8655 #ifdef MOMENT
8656       call transpose2(AEA(1,1,1),auxmatd(1,1))
8657       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8658       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8659       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8660 #endif
8661       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8662       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8663       s2d = scalar2(b1(1,k),vtemp1d(1))
8664 #ifdef MOMENT
8665       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8666       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8667 #endif
8668       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8669 #ifdef MOMENT
8670       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8671       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8672       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8673 #endif
8674 c      s1d=0.0d0
8675 c      s2d=0.0d0
8676 c      s8d=0.0d0
8677 c      s12d=0.0d0
8678 c      s13d=0.0d0
8679 #ifdef MOMENT
8680       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8681      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8682 #else
8683       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8684      &               -0.5d0*ekont*(s2d+s12d)
8685 #endif
8686 C Derivatives in gamma(i+4)
8687       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8688       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8689       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8690 #ifdef MOMENT
8691       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8692       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8693       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8694 #endif
8695 c      s1d=0.0d0
8696 c      s2d=0.0d0
8697 c      s8d=0.0d0
8698 C      s12d=0.0d0
8699 c      s13d=0.0d0
8700 #ifdef MOMENT
8701       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8702 #else
8703       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8704 #endif
8705 C Derivatives in gamma(i+5)
8706 #ifdef MOMENT
8707       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8708       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8709       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8710 #endif
8711       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8712       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8713       s2d = scalar2(b1(1,k),vtemp1d(1))
8714 #ifdef MOMENT
8715       call transpose2(AEA(1,1,2),atempd(1,1))
8716       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8717       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8718 #endif
8719       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8720       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8721 #ifdef MOMENT
8722       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8723       ss13d = scalar2(b1(1,k),vtemp4d(1))
8724       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8725 #endif
8726 c      s1d=0.0d0
8727 c      s2d=0.0d0
8728 c      s8d=0.0d0
8729 c      s12d=0.0d0
8730 c      s13d=0.0d0
8731 #ifdef MOMENT
8732       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8733      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8734 #else
8735       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8736      &               -0.5d0*ekont*(s2d+s12d)
8737 #endif
8738 C Cartesian derivatives
8739       do iii=1,2
8740         do kkk=1,5
8741           do lll=1,3
8742 #ifdef MOMENT
8743             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8744             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8745             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8746 #endif
8747             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8748             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8749      &          vtemp1d(1))
8750             s2d = scalar2(b1(1,k),vtemp1d(1))
8751 #ifdef MOMENT
8752             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8753             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8754             s8d = -(atempd(1,1)+atempd(2,2))*
8755      &           scalar2(cc(1,1,l),vtemp2(1))
8756 #endif
8757             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8758      &           auxmatd(1,1))
8759             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8760             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8761 c      s1d=0.0d0
8762 c      s2d=0.0d0
8763 c      s8d=0.0d0
8764 c      s12d=0.0d0
8765 c      s13d=0.0d0
8766 #ifdef MOMENT
8767             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8768      &        - 0.5d0*(s1d+s2d)
8769 #else
8770             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8771      &        - 0.5d0*s2d
8772 #endif
8773 #ifdef MOMENT
8774             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8775      &        - 0.5d0*(s8d+s12d)
8776 #else
8777             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8778      &        - 0.5d0*s12d
8779 #endif
8780           enddo
8781         enddo
8782       enddo
8783 #ifdef MOMENT
8784       do kkk=1,5
8785         do lll=1,3
8786           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8787      &      achuj_tempd(1,1))
8788           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8789           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8790           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8791           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8792           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8793      &      vtemp4d(1))
8794           ss13d = scalar2(b1(1,k),vtemp4d(1))
8795           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8796           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8797         enddo
8798       enddo
8799 #endif
8800 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8801 cd     &  16*eel_turn6_num
8802 cd      goto 1112
8803       if (j.lt.nres-1) then
8804         j1=j+1
8805         j2=j-1
8806       else
8807         j1=j-1
8808         j2=j-2
8809       endif
8810       if (l.lt.nres-1) then
8811         l1=l+1
8812         l2=l-1
8813       else
8814         l1=l-1
8815         l2=l-2
8816       endif
8817       do ll=1,3
8818 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8819 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8820 cgrad        ghalf=0.5d0*ggg1(ll)
8821 cd        ghalf=0.0d0
8822         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8823         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8824         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8825      &    +ekont*derx_turn(ll,2,1)
8826         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8827         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8828      &    +ekont*derx_turn(ll,4,1)
8829         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8830         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8831         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8832 cgrad        ghalf=0.5d0*ggg2(ll)
8833 cd        ghalf=0.0d0
8834         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8835      &    +ekont*derx_turn(ll,2,2)
8836         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8837         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8838      &    +ekont*derx_turn(ll,4,2)
8839         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8840         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8841         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8842       enddo
8843 cd      goto 1112
8844 cgrad      do m=i+1,j-1
8845 cgrad        do ll=1,3
8846 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8847 cgrad        enddo
8848 cgrad      enddo
8849 cgrad      do m=k+1,l-1
8850 cgrad        do ll=1,3
8851 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8852 cgrad        enddo
8853 cgrad      enddo
8854 cgrad1112  continue
8855 cgrad      do m=i+2,j2
8856 cgrad        do ll=1,3
8857 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8858 cgrad        enddo
8859 cgrad      enddo
8860 cgrad      do m=k+2,l2
8861 cgrad        do ll=1,3
8862 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8863 cgrad        enddo
8864 cgrad      enddo
8865 cd      do iii=1,nres-3
8866 cd        write (2,*) iii,g_corr6_loc(iii)
8867 cd      enddo
8868       endif ! calc_grad
8869       eello_turn6=ekont*eel_turn6
8870 cd      write (2,*) 'ekont',ekont
8871 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8872       return
8873       end
8874
8875 crc-------------------------------------------------
8876 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8877       subroutine Eliptransfer(eliptran)
8878       implicit real*8 (a-h,o-z)
8879       include 'DIMENSIONS'
8880       include 'COMMON.GEO'
8881       include 'COMMON.VAR'
8882       include 'COMMON.LOCAL'
8883       include 'COMMON.CHAIN'
8884       include 'COMMON.DERIV'
8885       include 'COMMON.INTERACT'
8886       include 'COMMON.IOUNITS'
8887       include 'COMMON.CALC'
8888       include 'COMMON.CONTROL'
8889       include 'COMMON.SPLITELE'
8890       include 'COMMON.SBRIDGE'
8891 C this is done by Adasko
8892 C      print *,"wchodze"
8893 C structure of box:
8894 C      water
8895 C--bordliptop-- buffore starts
8896 C--bufliptop--- here true lipid starts
8897 C      lipid
8898 C--buflipbot--- lipid ends buffore starts
8899 C--bordlipbot--buffore ends
8900       eliptran=0.0
8901       do i=1,nres
8902 C       do i=1,1
8903         if (itype(i).eq.ntyp1) cycle
8904
8905         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8906         if (positi.le.0) positi=positi+boxzsize
8907 C        print *,i
8908 C first for peptide groups
8909 c for each residue check if it is in lipid or lipid water border area
8910        if ((positi.gt.bordlipbot)
8911      &.and.(positi.lt.bordliptop)) then
8912 C the energy transfer exist
8913         if (positi.lt.buflipbot) then
8914 C what fraction I am in
8915          fracinbuf=1.0d0-
8916      &        ((positi-bordlipbot)/lipbufthick)
8917 C lipbufthick is thickenes of lipid buffore
8918          sslip=sscalelip(fracinbuf)
8919          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8920          eliptran=eliptran+sslip*pepliptran
8921          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8922          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8923 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8924         elseif (positi.gt.bufliptop) then
8925          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8926          sslip=sscalelip(fracinbuf)
8927          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8928          eliptran=eliptran+sslip*pepliptran
8929          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8930          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8931 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8932 C          print *, "doing sscalefor top part"
8933 C         print *,i,sslip,fracinbuf,ssgradlip
8934         else
8935          eliptran=eliptran+pepliptran
8936 C         print *,"I am in true lipid"
8937         endif
8938 C       else
8939 C       eliptran=elpitran+0.0 ! I am in water
8940        endif
8941        enddo
8942 C       print *, "nic nie bylo w lipidzie?"
8943 C now multiply all by the peptide group transfer factor
8944 C       eliptran=eliptran*pepliptran
8945 C now the same for side chains
8946 CV       do i=1,1
8947        do i=1,nres
8948         if (itype(i).eq.ntyp1) cycle
8949         positi=(mod(c(3,i+nres),boxzsize))
8950         if (positi.le.0) positi=positi+boxzsize
8951 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8952 c for each residue check if it is in lipid or lipid water border area
8953 C       respos=mod(c(3,i+nres),boxzsize)
8954 C       print *,positi,bordlipbot,buflipbot
8955        if ((positi.gt.bordlipbot)
8956      & .and.(positi.lt.bordliptop)) then
8957 C the energy transfer exist
8958         if (positi.lt.buflipbot) then
8959          fracinbuf=1.0d0-
8960      &     ((positi-bordlipbot)/lipbufthick)
8961 C lipbufthick is thickenes of lipid buffore
8962          sslip=sscalelip(fracinbuf)
8963          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8964          eliptran=eliptran+sslip*liptranene(itype(i))
8965          gliptranx(3,i)=gliptranx(3,i)
8966      &+ssgradlip*liptranene(itype(i))
8967          gliptranc(3,i-1)= gliptranc(3,i-1)
8968      &+ssgradlip*liptranene(itype(i))
8969 C         print *,"doing sccale for lower part"
8970         elseif (positi.gt.bufliptop) then
8971          fracinbuf=1.0d0-
8972      &((bordliptop-positi)/lipbufthick)
8973          sslip=sscalelip(fracinbuf)
8974          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8975          eliptran=eliptran+sslip*liptranene(itype(i))
8976          gliptranx(3,i)=gliptranx(3,i)
8977      &+ssgradlip*liptranene(itype(i))
8978          gliptranc(3,i-1)= gliptranc(3,i-1)
8979      &+ssgradlip*liptranene(itype(i))
8980 C          print *, "doing sscalefor top part",sslip,fracinbuf
8981         else
8982          eliptran=eliptran+liptranene(itype(i))
8983 C         print *,"I am in true lipid"
8984         endif
8985         endif ! if in lipid or buffor
8986 C       else
8987 C       eliptran=elpitran+0.0 ! I am in water
8988        enddo
8989        return
8990        end
8991
8992
8993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8994
8995       SUBROUTINE MATVEC2(A1,V1,V2)
8996       implicit real*8 (a-h,o-z)
8997       include 'DIMENSIONS'
8998       DIMENSION A1(2,2),V1(2),V2(2)
8999 c      DO 1 I=1,2
9000 c        VI=0.0
9001 c        DO 3 K=1,2
9002 c    3     VI=VI+A1(I,K)*V1(K)
9003 c        Vaux(I)=VI
9004 c    1 CONTINUE
9005
9006       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9007       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9008
9009       v2(1)=vaux1
9010       v2(2)=vaux2
9011       END
9012 C---------------------------------------
9013       SUBROUTINE MATMAT2(A1,A2,A3)
9014       implicit real*8 (a-h,o-z)
9015       include 'DIMENSIONS'
9016       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9017 c      DIMENSION AI3(2,2)
9018 c        DO  J=1,2
9019 c          A3IJ=0.0
9020 c          DO K=1,2
9021 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9022 c          enddo
9023 c          A3(I,J)=A3IJ
9024 c       enddo
9025 c      enddo
9026
9027       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9028       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9029       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9030       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9031
9032       A3(1,1)=AI3_11
9033       A3(2,1)=AI3_21
9034       A3(1,2)=AI3_12
9035       A3(2,2)=AI3_22
9036       END
9037
9038 c-------------------------------------------------------------------------
9039       double precision function scalar2(u,v)
9040       implicit none
9041       double precision u(2),v(2)
9042       double precision sc
9043       integer i
9044       scalar2=u(1)*v(1)+u(2)*v(2)
9045       return
9046       end
9047
9048 C-----------------------------------------------------------------------------
9049
9050       subroutine transpose2(a,at)
9051       implicit none
9052       double precision a(2,2),at(2,2)
9053       at(1,1)=a(1,1)
9054       at(1,2)=a(2,1)
9055       at(2,1)=a(1,2)
9056       at(2,2)=a(2,2)
9057       return
9058       end
9059 c--------------------------------------------------------------------------
9060       subroutine transpose(n,a,at)
9061       implicit none
9062       integer n,i,j
9063       double precision a(n,n),at(n,n)
9064       do i=1,n
9065         do j=1,n
9066           at(j,i)=a(i,j)
9067         enddo
9068       enddo
9069       return
9070       end
9071 C---------------------------------------------------------------------------
9072       subroutine prodmat3(a1,a2,kk,transp,prod)
9073       implicit none
9074       integer i,j
9075       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9076       logical transp
9077 crc      double precision auxmat(2,2),prod_(2,2)
9078
9079       if (transp) then
9080 crc        call transpose2(kk(1,1),auxmat(1,1))
9081 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9082 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9083
9084            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9085      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9086            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9087      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9088            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9089      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9090            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9091      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9092
9093       else
9094 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9095 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9096
9097            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9098      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9099            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9100      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9101            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9102      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9103            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9104      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9105
9106       endif
9107 c      call transpose2(a2(1,1),a2t(1,1))
9108
9109 crc      print *,transp
9110 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9111 crc      print *,((prod(i,j),i=1,2),j=1,2)
9112
9113       return
9114       end
9115 C-----------------------------------------------------------------------------
9116       double precision function scalar(u,v)
9117       implicit none
9118       double precision u(3),v(3)
9119       double precision sc
9120       integer i
9121       sc=0.0d0
9122       do i=1,3
9123         sc=sc+u(i)*v(i)
9124       enddo
9125       scalar=sc
9126       return
9127       end
9128 C-----------------------------------------------------------------------
9129       double precision function sscale(r)
9130       double precision r,gamm
9131       include "COMMON.SPLITELE"
9132       if(r.lt.r_cut-rlamb) then
9133         sscale=1.0d0
9134       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9135         gamm=(r-(r_cut-rlamb))/rlamb
9136         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9137       else
9138         sscale=0d0
9139       endif
9140       return
9141       end
9142 C-----------------------------------------------------------------------
9143 C-----------------------------------------------------------------------
9144       double precision function sscagrad(r)
9145       double precision r,gamm
9146       include "COMMON.SPLITELE"
9147       if(r.lt.r_cut-rlamb) then
9148         sscagrad=0.0d0
9149       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9150         gamm=(r-(r_cut-rlamb))/rlamb
9151         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9152       else
9153         sscagrad=0.0d0
9154       endif
9155       return
9156       end
9157 C-----------------------------------------------------------------------
9158 C-----------------------------------------------------------------------
9159       double precision function sscalelip(r)
9160       double precision r,gamm
9161       include "COMMON.SPLITELE"
9162 C      if(r.lt.r_cut-rlamb) then
9163 C        sscale=1.0d0
9164 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9165 C        gamm=(r-(r_cut-rlamb))/rlamb
9166         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9167 C      else
9168 C        sscale=0d0
9169 C      endif
9170       return
9171       end
9172 C-----------------------------------------------------------------------
9173       double precision function sscagradlip(r)
9174       double precision r,gamm
9175       include "COMMON.SPLITELE"
9176 C     if(r.lt.r_cut-rlamb) then
9177 C        sscagrad=0.0d0
9178 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9179 C        gamm=(r-(r_cut-rlamb))/rlamb
9180         sscagradlip=r*(6*r-6.0d0)
9181 C      else
9182 C        sscagrad=0.0d0
9183 C      endif
9184       return
9185       end
9186
9187 C-----------------------------------------------------------------------
9188        subroutine set_shield_fac
9189       implicit real*8 (a-h,o-z)
9190       include 'DIMENSIONS'
9191       include 'COMMON.CHAIN'
9192       include 'COMMON.DERIV'
9193       include 'COMMON.IOUNITS'
9194       include 'COMMON.SHIELD'
9195       include 'COMMON.INTERACT'
9196 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9197       double precision div77_81/0.974996043d0/,
9198      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9199
9200 C the vector between center of side_chain and peptide group
9201        double precision pep_side(3),long,side_calf(3),
9202      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9203      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9204 C the line belowe needs to be changed for FGPROC>1
9205       do i=1,nres-1
9206       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9207       ishield_list(i)=0
9208 Cif there two consequtive dummy atoms there is no peptide group between them
9209 C the line below has to be changed for FGPROC>1
9210       VolumeTotal=0.0
9211       do k=1,nres
9212        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9213        dist_pep_side=0.0
9214        dist_side_calf=0.0
9215        do j=1,3
9216 C first lets set vector conecting the ithe side-chain with kth side-chain
9217       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9218 C      pep_side(j)=2.0d0
9219 C and vector conecting the side-chain with its proper calfa
9220       side_calf(j)=c(j,k+nres)-c(j,k)
9221 C      side_calf(j)=2.0d0
9222       pept_group(j)=c(j,i)-c(j,i+1)
9223 C lets have their lenght
9224       dist_pep_side=pep_side(j)**2+dist_pep_side
9225       dist_side_calf=dist_side_calf+side_calf(j)**2
9226       dist_pept_group=dist_pept_group+pept_group(j)**2
9227       enddo
9228        dist_pep_side=dsqrt(dist_pep_side)
9229        dist_pept_group=dsqrt(dist_pept_group)
9230        dist_side_calf=dsqrt(dist_side_calf)
9231       do j=1,3
9232         pep_side_norm(j)=pep_side(j)/dist_pep_side
9233         side_calf_norm(j)=dist_side_calf
9234       enddo
9235 C now sscale fraction
9236        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9237 C       print *,buff_shield,"buff"
9238 C now sscale
9239         if (sh_frac_dist.le.0.0) cycle
9240 C If we reach here it means that this side chain reaches the shielding sphere
9241 C Lets add him to the list for gradient
9242         ishield_list(i)=ishield_list(i)+1
9243 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9244 C this list is essential otherwise problem would be O3
9245         shield_list(ishield_list(i),i)=k
9246 C Lets have the sscale value
9247         if (sh_frac_dist.gt.1.0) then
9248          scale_fac_dist=1.0d0
9249          do j=1,3
9250          sh_frac_dist_grad(j)=0.0d0
9251          enddo
9252         else
9253          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9254      &                   *(2.0*sh_frac_dist-3.0d0)
9255          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9256      &                  /dist_pep_side/buff_shield*0.5
9257 C remember for the final gradient multiply sh_frac_dist_grad(j)
9258 C for side_chain by factor -2 !
9259          do j=1,3
9260          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9261 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9262 C     &                    sh_frac_dist_grad(j)
9263          enddo
9264         endif
9265 C        if ((i.eq.3).and.(k.eq.2)) then
9266 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9267 C     & ,"TU"
9268 C        endif
9269
9270 C this is what is now we have the distance scaling now volume...
9271       short=short_r_sidechain(itype(k))
9272       long=long_r_sidechain(itype(k))
9273       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9274 C now costhet_grad
9275 C       costhet=0.0d0
9276        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9277 C       costhet_fac=0.0d0
9278        do j=1,3
9279          costhet_grad(j)=costhet_fac*pep_side(j)
9280        enddo
9281 C remember for the final gradient multiply costhet_grad(j)
9282 C for side_chain by factor -2 !
9283 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9284 C pep_side0pept_group is vector multiplication
9285       pep_side0pept_group=0.0
9286       do j=1,3
9287       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9288       enddo
9289       cosalfa=(pep_side0pept_group/
9290      & (dist_pep_side*dist_side_calf))
9291       fac_alfa_sin=1.0-cosalfa**2
9292       fac_alfa_sin=dsqrt(fac_alfa_sin)
9293       rkprim=fac_alfa_sin*(long-short)+short
9294 C now costhet_grad
9295        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9296        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9297
9298        do j=1,3
9299          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9300      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9301      &*(long-short)/fac_alfa_sin*cosalfa/
9302      &((dist_pep_side*dist_side_calf))*
9303      &((side_calf(j))-cosalfa*
9304      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9305
9306         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9307      &*(long-short)/fac_alfa_sin*cosalfa
9308      &/((dist_pep_side*dist_side_calf))*
9309      &(pep_side(j)-
9310      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9311        enddo
9312
9313       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9314      &                    /VSolvSphere_div
9315      &                    *wshield
9316 C now the gradient...
9317 C grad_shield is gradient of Calfa for peptide groups
9318 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9319 C     &               costhet,cosphi
9320 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9321 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9322       do j=1,3
9323       grad_shield(j,i)=grad_shield(j,i)
9324 C gradient po skalowaniu
9325      &                +(sh_frac_dist_grad(j)
9326 C  gradient po costhet
9327      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9328      &-scale_fac_dist*(cosphi_grad_long(j))
9329      &/(1.0-cosphi) )*div77_81
9330      &*VofOverlap
9331 C grad_shield_side is Cbeta sidechain gradient
9332       grad_shield_side(j,ishield_list(i),i)=
9333      &        (sh_frac_dist_grad(j)*(-2.0d0)
9334      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9335      &       +scale_fac_dist*(cosphi_grad_long(j))
9336      &        *2.0d0/(1.0-cosphi))
9337      &        *div77_81*VofOverlap
9338
9339        grad_shield_loc(j,ishield_list(i),i)=
9340      &   scale_fac_dist*cosphi_grad_loc(j)
9341      &        *2.0d0/(1.0-cosphi)
9342      &        *div77_81*VofOverlap
9343       enddo
9344       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9345       enddo
9346       fac_shield(i)=VolumeTotal*div77_81+div4_81
9347 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9348       enddo
9349       return
9350       end
9351 C--------------------------------------------------------------------------
9352 C first for shielding is setting of function of side-chains
9353        subroutine set_shield_fac2
9354       implicit real*8 (a-h,o-z)
9355       include 'DIMENSIONS'
9356       include 'COMMON.CHAIN'
9357       include 'COMMON.DERIV'
9358       include 'COMMON.IOUNITS'
9359       include 'COMMON.SHIELD'
9360       include 'COMMON.INTERACT'
9361 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9362       double precision div77_81/0.974996043d0/,
9363      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9364
9365 C the vector between center of side_chain and peptide group
9366        double precision pep_side(3),long,side_calf(3),
9367      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9368      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9369 C the line belowe needs to be changed for FGPROC>1
9370       do i=1,nres-1
9371       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9372       ishield_list(i)=0
9373 Cif there two consequtive dummy atoms there is no peptide group between them
9374 C the line below has to be changed for FGPROC>1
9375       VolumeTotal=0.0
9376       do k=1,nres
9377        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9378        dist_pep_side=0.0
9379        dist_side_calf=0.0
9380        do j=1,3
9381 C first lets set vector conecting the ithe side-chain with kth side-chain
9382       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9383 C      pep_side(j)=2.0d0
9384 C and vector conecting the side-chain with its proper calfa
9385       side_calf(j)=c(j,k+nres)-c(j,k)
9386 C      side_calf(j)=2.0d0
9387       pept_group(j)=c(j,i)-c(j,i+1)
9388 C lets have their lenght
9389       dist_pep_side=pep_side(j)**2+dist_pep_side
9390       dist_side_calf=dist_side_calf+side_calf(j)**2
9391       dist_pept_group=dist_pept_group+pept_group(j)**2
9392       enddo
9393        dist_pep_side=dsqrt(dist_pep_side)
9394        dist_pept_group=dsqrt(dist_pept_group)
9395        dist_side_calf=dsqrt(dist_side_calf)
9396       do j=1,3
9397         pep_side_norm(j)=pep_side(j)/dist_pep_side
9398         side_calf_norm(j)=dist_side_calf
9399       enddo
9400 C now sscale fraction
9401        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9402 C       print *,buff_shield,"buff"
9403 C now sscale
9404         if (sh_frac_dist.le.0.0) cycle
9405 C If we reach here it means that this side chain reaches the shielding sphere
9406 C Lets add him to the list for gradient
9407         ishield_list(i)=ishield_list(i)+1
9408 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9409 C this list is essential otherwise problem would be O3
9410         shield_list(ishield_list(i),i)=k
9411 C Lets have the sscale value
9412         if (sh_frac_dist.gt.1.0) then
9413          scale_fac_dist=1.0d0
9414          do j=1,3
9415          sh_frac_dist_grad(j)=0.0d0
9416          enddo
9417         else
9418          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9419      &                   *(2.0d0*sh_frac_dist-3.0d0)
9420          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9421      &                  /dist_pep_side/buff_shield*0.5d0
9422 C remember for the final gradient multiply sh_frac_dist_grad(j)
9423 C for side_chain by factor -2 !
9424          do j=1,3
9425          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9426 C         sh_frac_dist_grad(j)=0.0d0
9427 C         scale_fac_dist=1.0d0
9428 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9429 C     &                    sh_frac_dist_grad(j)
9430          enddo
9431         endif
9432 C this is what is now we have the distance scaling now volume...
9433       short=short_r_sidechain(itype(k))
9434       long=long_r_sidechain(itype(k))
9435       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9436       sinthet=short/dist_pep_side*costhet
9437 C now costhet_grad
9438 C       costhet=0.6d0
9439 C       sinthet=0.8
9440        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9441 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9442 C     &             -short/dist_pep_side**2/costhet)
9443 C       costhet_fac=0.0d0
9444        do j=1,3
9445          costhet_grad(j)=costhet_fac*pep_side(j)
9446        enddo
9447 C remember for the final gradient multiply costhet_grad(j)
9448 C for side_chain by factor -2 !
9449 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9450 C pep_side0pept_group is vector multiplication
9451       pep_side0pept_group=0.0d0
9452       do j=1,3
9453       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9454       enddo
9455       cosalfa=(pep_side0pept_group/
9456      & (dist_pep_side*dist_side_calf))
9457       fac_alfa_sin=1.0d0-cosalfa**2
9458       fac_alfa_sin=dsqrt(fac_alfa_sin)
9459       rkprim=fac_alfa_sin*(long-short)+short
9460 C      rkprim=short
9461
9462 C now costhet_grad
9463        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9464 C       cosphi=0.6
9465        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9466        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9467      &      dist_pep_side**2)
9468 C       sinphi=0.8
9469        do j=1,3
9470          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9471      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9472      &*(long-short)/fac_alfa_sin*cosalfa/
9473      &((dist_pep_side*dist_side_calf))*
9474      &((side_calf(j))-cosalfa*
9475      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9476 C       cosphi_grad_long(j)=0.0d0
9477         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9478      &*(long-short)/fac_alfa_sin*cosalfa
9479      &/((dist_pep_side*dist_side_calf))*
9480      &(pep_side(j)-
9481      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9482 C       cosphi_grad_loc(j)=0.0d0
9483        enddo
9484 C      print *,sinphi,sinthet
9485       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9486      &                    /VSolvSphere_div
9487 C     &                    *wshield
9488 C now the gradient...
9489       do j=1,3
9490       grad_shield(j,i)=grad_shield(j,i)
9491 C gradient po skalowaniu
9492      &                +(sh_frac_dist_grad(j)*VofOverlap
9493 C  gradient po costhet
9494      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9495      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9496      &       sinphi/sinthet*costhet*costhet_grad(j)
9497      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9498      & )*wshield
9499 C grad_shield_side is Cbeta sidechain gradient
9500       grad_shield_side(j,ishield_list(i),i)=
9501      &        (sh_frac_dist_grad(j)*(-2.0d0)
9502      &        *VofOverlap
9503      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9504      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9505      &       sinphi/sinthet*costhet*costhet_grad(j)
9506      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9507      &       )*wshield
9508
9509        grad_shield_loc(j,ishield_list(i),i)=
9510      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9511      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9512      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9513      &        ))
9514      &        *wshield
9515       enddo
9516       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9517       enddo
9518       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9519 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9520 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9521       enddo
9522       return
9523       end
9524 C--------------------------------------------------------------------------
9525       double precision function tschebyshev(m,n,x,y)
9526       implicit none
9527       include "DIMENSIONS"
9528       integer i,m,n
9529       double precision x(n),y,yy(0:maxvar),aux
9530 c Tschebyshev polynomial. Note that the first term is omitted
9531 c m=0: the constant term is included
9532 c m=1: the constant term is not included
9533       yy(0)=1.0d0
9534       yy(1)=y
9535       do i=2,n
9536         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9537       enddo
9538       aux=0.0d0
9539       do i=m,n
9540         aux=aux+x(i)*yy(i)
9541       enddo
9542       tschebyshev=aux
9543       return
9544       end
9545 C--------------------------------------------------------------------------
9546       double precision function gradtschebyshev(m,n,x,y)
9547       implicit none
9548       include "DIMENSIONS"
9549       integer i,m,n
9550       double precision x(n+1),y,yy(0:maxvar),aux
9551 c Tschebyshev polynomial. Note that the first term is omitted
9552 c m=0: the constant term is included
9553 c m=1: the constant term is not included
9554       yy(0)=1.0d0
9555       yy(1)=2.0d0*y
9556       do i=2,n
9557         yy(i)=2*y*yy(i-1)-yy(i-2)
9558       enddo
9559       aux=0.0d0
9560       do i=m,n
9561         aux=aux+x(i+1)*yy(i)*(i+1)
9562 C        print *, x(i+1),yy(i),i
9563       enddo
9564       gradtschebyshev=aux
9565       return
9566       end
9567 c----------------------------------------------------------------------------
9568       double precision function sscale2(r,r_cut,r0,rlamb)
9569       implicit none
9570       double precision r,gamm,r_cut,r0,rlamb,rr
9571       rr = dabs(r-r0)
9572 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9573 c      write (2,*) "rr",rr
9574       if(rr.lt.r_cut-rlamb) then
9575         sscale2=1.0d0
9576       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9577         gamm=(rr-(r_cut-rlamb))/rlamb
9578         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9579       else
9580         sscale2=0d0
9581       endif
9582       return
9583       end
9584 C-----------------------------------------------------------------------
9585       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9586       implicit none
9587       double precision r,gamm,r_cut,r0,rlamb,rr
9588       rr = dabs(r-r0)
9589       if(rr.lt.r_cut-rlamb) then
9590         sscalgrad2=0.0d0
9591       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9592         gamm=(rr-(r_cut-rlamb))/rlamb
9593         if (r.ge.r0) then
9594           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9595         else
9596           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9597         endif
9598       else
9599         sscalgrad2=0.0d0
9600       endif
9601       return
9602       end
9603 c----------------------------------------------------------------------------
9604       subroutine e_saxs(Esaxs_constr)
9605       implicit none
9606       include 'DIMENSIONS'
9607 #ifdef MPI
9608       include "mpif.h"
9609       include "COMMON.SETUP"
9610       integer IERR
9611 #endif
9612       include 'COMMON.SBRIDGE'
9613       include 'COMMON.CHAIN'
9614       include 'COMMON.GEO'
9615       include 'COMMON.LOCAL'
9616       include 'COMMON.INTERACT'
9617       include 'COMMON.VAR'
9618       include 'COMMON.IOUNITS'
9619       include 'COMMON.DERIV'
9620       include 'COMMON.CONTROL'
9621       include 'COMMON.NAMES'
9622       include 'COMMON.FFIELD'
9623       include 'COMMON.LANGEVIN'
9624       include 'COMMON.SAXS'
9625 c
9626       double precision Esaxs_constr
9627       integer i,iint,j,k,l
9628       double precision PgradC(maxSAXS,3,maxres),
9629      &  PgradX(maxSAXS,3,maxres)
9630 #ifdef MPI
9631       double precision PgradC_(maxSAXS,3,maxres),
9632      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9633 #endif
9634       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9635      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9636      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9637      & auxX,auxX1,CACAgrad,Cnorm
9638       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9639       double precision dist
9640       external dist
9641 c  SAXS restraint penalty function
9642 #ifdef DEBUG
9643       write(iout,*) "------- SAXS penalty function start -------"
9644       write (iout,*) "nsaxs",nsaxs
9645       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9646       write (iout,*) "Psaxs"
9647       do i=1,nsaxs
9648         write (iout,'(i5,e15.5)') i, Psaxs(i)
9649       enddo
9650 #endif
9651       Esaxs_constr = 0.0d0
9652       do k=1,nsaxs
9653         Pcalc(k)=0.0d0
9654         do j=1,nres
9655           do l=1,3
9656             PgradC(k,l,j)=0.0d0
9657             PgradX(k,l,j)=0.0d0
9658           enddo
9659         enddo
9660       enddo
9661       do i=iatsc_s,iatsc_e
9662        if (itype(i).eq.ntyp1) cycle
9663        do iint=1,nint_gr(i)
9664          do j=istart(i,iint),iend(i,iint)
9665            if (itype(j).eq.ntyp1) cycle
9666 #ifdef ALLSAXS
9667            dijCACA=dist(i,j)
9668            dijCASC=dist(i,j+nres)
9669            dijSCCA=dist(i+nres,j)
9670            dijSCSC=dist(i+nres,j+nres)
9671            sigma2CACA=2.0d0/(pstok**2)
9672            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9673            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9674            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9675            do k=1,nsaxs
9676              dk = distsaxs(k)
9677              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9678              if (itype(j).ne.10) then
9679              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9680              else
9681              endif
9682              expCASC = 0.0d0
9683              if (itype(i).ne.10) then
9684              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9685              else
9686              expSCCA = 0.0d0
9687              endif
9688              if (itype(i).ne.10 .and. itype(j).ne.10) then
9689              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9690              else
9691              expSCSC = 0.0d0
9692              endif
9693              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9694 #ifdef DEBUG
9695              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9696 #endif
9697              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9698              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9699              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9700              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9701              do l=1,3
9702 c CA CA
9703                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9704                PgradC(k,l,i) = PgradC(k,l,i)-aux
9705                PgradC(k,l,j) = PgradC(k,l,j)+aux
9706 c CA SC
9707                if (itype(j).ne.10) then
9708                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9709                PgradC(k,l,i) = PgradC(k,l,i)-aux
9710                PgradC(k,l,j) = PgradC(k,l,j)+aux
9711                PgradX(k,l,j) = PgradX(k,l,j)+aux
9712                endif
9713 c SC CA
9714                if (itype(i).ne.10) then
9715                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9716                PgradX(k,l,i) = PgradX(k,l,i)-aux
9717                PgradC(k,l,i) = PgradC(k,l,i)-aux
9718                PgradC(k,l,j) = PgradC(k,l,j)+aux
9719                endif
9720 c SC SC
9721                if (itype(i).ne.10 .and. itype(j).ne.10) then
9722                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9723                PgradC(k,l,i) = PgradC(k,l,i)-aux
9724                PgradC(k,l,j) = PgradC(k,l,j)+aux
9725                PgradX(k,l,i) = PgradX(k,l,i)-aux
9726                PgradX(k,l,j) = PgradX(k,l,j)+aux
9727                endif
9728              enddo ! l
9729            enddo ! k
9730 #else
9731            dijCACA=dist(i,j)
9732            sigma2CACA=scal_rad**2*0.25d0/
9733      &        (restok(itype(j))**2+restok(itype(i))**2)
9734
9735            IF (saxs_cutoff.eq.0) THEN
9736            do k=1,nsaxs
9737              dk = distsaxs(k)
9738              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9739              Pcalc(k) = Pcalc(k)+expCACA
9740              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9741              do l=1,3
9742                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9743                PgradC(k,l,i) = PgradC(k,l,i)-aux
9744                PgradC(k,l,j) = PgradC(k,l,j)+aux
9745              enddo ! l
9746            enddo ! k
9747            ELSE
9748            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9749            do k=1,nsaxs
9750              dk = distsaxs(k)
9751 c             write (2,*) "ijk",i,j,k
9752              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9753              if (sss2.eq.0.0d0) cycle
9754              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9755              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9756              Pcalc(k) = Pcalc(k)+expCACA
9757 #ifdef DEBUG
9758              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9759 #endif
9760              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9761      &             ssgrad2*expCACA/sss2
9762              do l=1,3
9763 c CA CA
9764                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9765                PgradC(k,l,i) = PgradC(k,l,i)+aux
9766                PgradC(k,l,j) = PgradC(k,l,j)-aux
9767              enddo ! l
9768            enddo ! k
9769            ENDIF
9770 #endif
9771          enddo ! j
9772        enddo ! iint
9773       enddo ! i
9774 #ifdef MPI
9775       if (nfgtasks.gt.1) then
9776         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9777      &    MPI_SUM,king,FG_COMM,IERR)
9778         if (fg_rank.eq.king) then
9779           do k=1,nsaxs
9780             Pcalc(k) = Pcalc_(k)
9781           enddo
9782         endif
9783         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9784      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9785         if (fg_rank.eq.king) then
9786           do i=1,nres
9787             do l=1,3
9788               do k=1,nsaxs
9789                 PgradC(k,l,i) = PgradC_(k,l,i)
9790               enddo
9791             enddo
9792           enddo
9793         endif
9794 #ifdef ALLSAXS
9795         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9796      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9797         if (fg_rank.eq.king) then
9798           do i=1,nres
9799             do l=1,3
9800               do k=1,nsaxs
9801                 PgradX(k,l,i) = PgradX_(k,l,i)
9802               enddo
9803             enddo
9804           enddo
9805         endif
9806 #endif
9807       endif
9808 #endif
9809 #ifdef MPI
9810       if (fg_rank.eq.king) then
9811 #endif
9812       Cnorm = 0.0d0
9813       do k=1,nsaxs
9814         Cnorm = Cnorm + Pcalc(k)
9815       enddo
9816       Esaxs_constr = dlog(Cnorm)-wsaxs0
9817       do k=1,nsaxs
9818         if (Pcalc(k).gt.0.0d0)
9819      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9820 #ifdef DEBUG
9821         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9822 #endif
9823       enddo
9824 #ifdef DEBUG
9825       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9826 #endif
9827       do i=nnt,nct
9828         do l=1,3
9829           auxC=0.0d0
9830           auxC1=0.0d0
9831           auxX=0.0d0
9832           auxX1=0.d0
9833           do k=1,nsaxs
9834             if (Pcalc(k).gt.0)
9835      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9836             auxC1 = auxC1+PgradC(k,l,i)
9837 #ifdef ALLSAXS
9838             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9839             auxX1 = auxX1+PgradX(k,l,i)
9840 #endif
9841           enddo
9842           gsaxsC(l,i) = auxC - auxC1/Cnorm
9843 #ifdef ALLSAXS
9844           gsaxsX(l,i) = auxX - auxX1/Cnorm
9845 #endif
9846 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9847 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9848         enddo
9849       enddo
9850 #ifdef MPI
9851       endif
9852 #endif
9853       return
9854       end
9855 c----------------------------------------------------------------------------
9856       subroutine e_saxsC(Esaxs_constr)
9857       implicit none
9858       include 'DIMENSIONS'
9859 #ifdef MPI
9860       include "mpif.h"
9861       include "COMMON.SETUP"
9862       integer IERR
9863 #endif
9864       include 'COMMON.SBRIDGE'
9865       include 'COMMON.CHAIN'
9866       include 'COMMON.GEO'
9867       include 'COMMON.LOCAL'
9868       include 'COMMON.INTERACT'
9869       include 'COMMON.VAR'
9870       include 'COMMON.IOUNITS'
9871       include 'COMMON.DERIV'
9872       include 'COMMON.CONTROL'
9873       include 'COMMON.NAMES'
9874       include 'COMMON.FFIELD'
9875       include 'COMMON.LANGEVIN'
9876       include 'COMMON.SAXS'
9877 c
9878       double precision Esaxs_constr
9879       integer i,iint,j,k,l
9880       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
9881 #ifdef MPI
9882       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9883 #endif
9884       double precision dk,dijCASPH,dijSCSPH,
9885      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9886      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9887      & auxX,auxX1,Cnorm
9888 c  SAXS restraint penalty function
9889 #ifdef DEBUG
9890       write(iout,*) "------- SAXS penalty function start -------"
9891       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9892      & " isaxs_end",isaxs_end
9893       write (iout,*) "nnt",nnt," ntc",nct
9894       do i=nnt,nct
9895         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9896      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9897       enddo
9898       do i=nnt,nct
9899         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9900       enddo
9901 #endif
9902       Esaxs_constr = 0.0d0
9903       logPtot=0.0d0
9904       do j=isaxs_start,isaxs_end
9905         Pcalc_=0.0d0
9906         do i=1,nres
9907           do l=1,3
9908             PgradC(l,i)=0.0d0
9909             PgradX(l,i)=0.0d0
9910           enddo
9911         enddo
9912         do i=nnt,nct
9913           dijCASPH=0.0d0
9914           dijSCSPH=0.0d0
9915           do l=1,3
9916             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9917           enddo
9918           if (itype(i).ne.10) then
9919           do l=1,3
9920             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9921           enddo
9922           endif
9923           sigma2CA=2.0d0/pstok**2
9924           sigma2SC=4.0d0/restok(itype(i))**2
9925           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9926           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9927           Pcalc_ = Pcalc_+expCASPH+expSCSPH
9928 #ifdef DEBUG
9929           write(*,*) "processor i j Pcalc",
9930      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
9931 #endif
9932           CASPHgrad = sigma2CA*expCASPH
9933           SCSPHgrad = sigma2SC*expSCSPH
9934           do l=1,3
9935             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9936             PgradX(l,i) = PgradX(l,i) + aux
9937             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9938           enddo ! l
9939         enddo ! i
9940         do i=nnt,nct
9941           do l=1,3
9942             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
9943             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
9944           enddo
9945         enddo
9946         logPtot = logPtot - dlog(Pcalc_)
9947 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
9948 c     &    " logPtot",logPtot
9949       enddo ! j
9950 #ifdef MPI
9951       if (nfgtasks.gt.1) then
9952 c        write (iout,*) "logPtot before reduction",logPtot
9953         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9954      &    MPI_SUM,king,FG_COMM,IERR)
9955         logPtot = logPtot_
9956 c        write (iout,*) "logPtot after reduction",logPtot
9957         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9958      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9959         if (fg_rank.eq.king) then
9960           do i=1,nres
9961             do l=1,3
9962               gsaxsC(l,i) = gsaxsC_(l,i)
9963             enddo
9964           enddo
9965         endif
9966         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9967      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9968         if (fg_rank.eq.king) then
9969           do i=1,nres
9970             do l=1,3
9971               gsaxsX(l,i) = gsaxsX_(l,i)
9972             enddo
9973           enddo
9974         endif
9975       endif
9976 #endif
9977       Esaxs_constr = logPtot
9978       return
9979       end
9980 C--------------------------------------------------------------------------
9981 c MODELLER restraint function
9982       subroutine e_modeller(ehomology_constr)
9983       implicit real*8 (a-h,o-z)
9984       include 'DIMENSIONS'
9985       integer nnn, i, j, k, ki, irec, l
9986       integer katy, odleglosci, test7
9987       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
9988       real*8 distance(max_template),distancek(max_template),
9989      &    min_odl,godl(max_template),dih_diff(max_template)
9990
9991 c
9992 c     FP - 30/10/2014 Temporary specifications for homology restraints
9993 c
9994       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
9995      &                 sgtheta
9996       double precision, dimension (maxres) :: guscdiff,usc_diff
9997       double precision, dimension (max_template) ::
9998      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
9999      &           theta_diff
10000
10001       include 'COMMON.SBRIDGE'
10002       include 'COMMON.CHAIN'
10003       include 'COMMON.GEO'
10004       include 'COMMON.DERIV'
10005       include 'COMMON.LOCAL'
10006       include 'COMMON.INTERACT'
10007       include 'COMMON.VAR'
10008       include 'COMMON.IOUNITS'
10009       include 'COMMON.CONTROL'
10010       include 'COMMON.HOMRESTR'
10011       include 'COMMON.HOMOLOGY'
10012       include 'COMMON.SETUP'
10013       include 'COMMON.NAMES'
10014
10015       do i=1,max_template
10016         distancek(i)=9999999.9
10017       enddo
10018
10019       odleg=0.0d0
10020
10021 c Pseudo-energy and gradient from homology restraints (MODELLER-like
10022 c function)
10023 C AL 5/2/14 - Introduce list of restraints
10024 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
10025 #ifdef DEBUG
10026       write(iout,*) "------- dist restrs start -------"
10027 #endif
10028       do ii = link_start_homo,link_end_homo
10029          i = ires_homo(ii)
10030          j = jres_homo(ii)
10031          dij=dist(i,j)
10032 c        write (iout,*) "dij(",i,j,") =",dij
10033          nexl=0
10034          do k=1,constr_homology
10035            if(.not.l_homo(k,ii)) then
10036               nexl=nexl+1
10037               cycle
10038            endif
10039            distance(k)=odl(k,ii)-dij
10040 c          write (iout,*) "distance(",k,") =",distance(k)
10041 c
10042 c          For Gaussian-type Urestr
10043 c
10044            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
10045 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
10046 c          write (iout,*) "distancek(",k,") =",distancek(k)
10047 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
10048 c
10049 c          For Lorentzian-type Urestr
10050 c
10051            if (waga_dist.lt.0.0d0) then
10052               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10053               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10054      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10055            endif
10056          enddo
10057
10058 c         min_odl=minval(distancek)
10059          do kk=1,constr_homology
10060           if(l_homo(kk,ii)) then
10061             min_odl=distancek(kk)
10062             exit
10063           endif
10064          enddo
10065          do kk=1,constr_homology
10066           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10067      &              min_odl=distancek(kk)
10068          enddo
10069 c        write (iout,* )"min_odl",min_odl
10070 #ifdef DEBUG
10071          write (iout,*) "ij dij",i,j,dij
10072          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10073          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10074          write (iout,* )"min_odl",min_odl
10075 #endif
10076 #ifdef OLDRESTR
10077          odleg2=0.0d0
10078 #else
10079          if (waga_dist.ge.0.0d0) then
10080            odleg2=nexl
10081          else
10082            odleg2=0.0d0
10083          endif
10084 #endif
10085          do k=1,constr_homology
10086 c Nie wiem po co to liczycie jeszcze raz!
10087 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10088 c     &              (2*(sigma_odl(i,j,k))**2))
10089            if(.not.l_homo(k,ii)) cycle
10090            if (waga_dist.ge.0.0d0) then
10091 c
10092 c          For Gaussian-type Urestr
10093 c
10094             godl(k)=dexp(-distancek(k)+min_odl)
10095             odleg2=odleg2+godl(k)
10096 c
10097 c          For Lorentzian-type Urestr
10098 c
10099            else
10100             odleg2=odleg2+distancek(k)
10101            endif
10102
10103 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10104 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10105 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10106 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10107
10108          enddo
10109 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10110 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10111 #ifdef DEBUG
10112          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10113          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10114 #endif
10115            if (waga_dist.ge.0.0d0) then
10116 c
10117 c          For Gaussian-type Urestr
10118 c
10119               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10120 c
10121 c          For Lorentzian-type Urestr
10122 c
10123            else
10124               odleg=odleg+odleg2/constr_homology
10125            endif
10126 c
10127 #ifdef GRAD
10128 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10129 c Gradient
10130 c
10131 c          For Gaussian-type Urestr
10132 c
10133          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10134          sum_sgodl=0.0d0
10135          do k=1,constr_homology
10136 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10137 c     &           *waga_dist)+min_odl
10138 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10139 c
10140          if(.not.l_homo(k,ii)) cycle
10141          if (waga_dist.ge.0.0d0) then
10142 c          For Gaussian-type Urestr
10143 c
10144            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10145 c
10146 c          For Lorentzian-type Urestr
10147 c
10148          else
10149            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10150      &           sigma_odlir(k,ii)**2)**2)
10151          endif
10152            sum_sgodl=sum_sgodl+sgodl
10153
10154 c            sgodl2=sgodl2+sgodl
10155 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10156 c      write(iout,*) "constr_homology=",constr_homology
10157 c      write(iout,*) i, j, k, "TEST K"
10158          enddo
10159          if (waga_dist.ge.0.0d0) then
10160 c
10161 c          For Gaussian-type Urestr
10162 c
10163             grad_odl3=waga_homology(iset)*waga_dist
10164      &                *sum_sgodl/(sum_godl*dij)
10165 c
10166 c          For Lorentzian-type Urestr
10167 c
10168          else
10169 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10170 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10171             grad_odl3=-waga_homology(iset)*waga_dist*
10172      &                sum_sgodl/(constr_homology*dij)
10173          endif
10174 c
10175 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10176
10177
10178 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10179 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10180 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10181
10182 ccc      write(iout,*) godl, sgodl, grad_odl3
10183
10184 c          grad_odl=grad_odl+grad_odl3
10185
10186          do jik=1,3
10187             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10188 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10189 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10190 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10191             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10192             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10193 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10194 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10195 c         if (i.eq.25.and.j.eq.27) then
10196 c         write(iout,*) "jik",jik,"i",i,"j",j
10197 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10198 c         write(iout,*) "grad_odl3",grad_odl3
10199 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10200 c         write(iout,*) "ggodl",ggodl
10201 c         write(iout,*) "ghpbc(",jik,i,")",
10202 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10203 c     &                 ghpbc(jik,j)
10204 c         endif
10205          enddo
10206 #endif
10207 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10208 ccc     & dLOG(odleg2),"-odleg=", -odleg
10209
10210       enddo ! ii-loop for dist
10211 #ifdef DEBUG
10212       write(iout,*) "------- dist restrs end -------"
10213 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10214 c    &     waga_d.eq.1.0d0) call sum_gradient
10215 #endif
10216 c Pseudo-energy and gradient from dihedral-angle restraints from
10217 c homology templates
10218 c      write (iout,*) "End of distance loop"
10219 c      call flush(iout)
10220       kat=0.0d0
10221 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10222 #ifdef DEBUG
10223       write(iout,*) "------- dih restrs start -------"
10224       do i=idihconstr_start_homo,idihconstr_end_homo
10225         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10226       enddo
10227 #endif
10228       do i=idihconstr_start_homo,idihconstr_end_homo
10229         kat2=0.0d0
10230 c        betai=beta(i,i+1,i+2,i+3)
10231         betai = phi(i)
10232 c       write (iout,*) "betai =",betai
10233         do k=1,constr_homology
10234           dih_diff(k)=pinorm(dih(k,i)-betai)
10235 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10236 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10237 c     &                                   -(6.28318-dih_diff(i,k))
10238 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10239 c     &                                   6.28318+dih_diff(i,k)
10240 #ifdef OLD_DIHED
10241           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10242 #else
10243           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10244 #endif
10245 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10246           gdih(k)=dexp(kat3)
10247           kat2=kat2+gdih(k)
10248 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10249 c          write(*,*)""
10250         enddo
10251 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10252 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10253 #ifdef DEBUG
10254         write (iout,*) "i",i," betai",betai," kat2",kat2
10255         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10256 #endif
10257         if (kat2.le.1.0d-14) cycle
10258         kat=kat-dLOG(kat2/constr_homology)
10259 c       write (iout,*) "kat",kat ! sum of -ln-s
10260
10261 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10262 ccc     & dLOG(kat2), "-kat=", -kat
10263
10264 #ifdef GRAD
10265 c ----------------------------------------------------------------------
10266 c Gradient
10267 c ----------------------------------------------------------------------
10268
10269         sum_gdih=kat2
10270         sum_sgdih=0.0d0
10271         do k=1,constr_homology
10272 #ifdef OLD_DIHED
10273           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10274 #else
10275           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10276 #endif
10277 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10278           sum_sgdih=sum_sgdih+sgdih
10279         enddo
10280 c       grad_dih3=sum_sgdih/sum_gdih
10281         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10282
10283 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10284 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10285 ccc     & gloc(nphi+i-3,icg)
10286         gloc(i,icg)=gloc(i,icg)+grad_dih3
10287 c        if (i.eq.25) then
10288 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10289 c        endif
10290 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10291 ccc     & gloc(nphi+i-3,icg)
10292 #endif
10293       enddo ! i-loop for dih
10294 #ifdef DEBUG
10295       write(iout,*) "------- dih restrs end -------"
10296 #endif
10297
10298 c Pseudo-energy and gradient for theta angle restraints from
10299 c homology templates
10300 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10301 c adapted
10302
10303 c
10304 c     For constr_homology reference structures (FP)
10305 c
10306 c     Uconst_back_tot=0.0d0
10307       Eval=0.0d0
10308       Erot=0.0d0
10309 c     Econstr_back legacy
10310 #ifdef GRAD
10311       do i=1,nres
10312 c     do i=ithet_start,ithet_end
10313        dutheta(i)=0.0d0
10314 c     enddo
10315 c     do i=loc_start,loc_end
10316         do j=1,3
10317           duscdiff(j,i)=0.0d0
10318           duscdiffx(j,i)=0.0d0
10319         enddo
10320       enddo
10321 #endif
10322 c
10323 c     do iref=1,nref
10324 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10325 c     write (iout,*) "waga_theta",waga_theta
10326       if (waga_theta.gt.0.0d0) then
10327 #ifdef DEBUG
10328       write (iout,*) "usampl",usampl
10329       write(iout,*) "------- theta restrs start -------"
10330 c     do i=ithet_start,ithet_end
10331 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10332 c     enddo
10333 #endif
10334 c     write (iout,*) "maxres",maxres,"nres",nres
10335
10336       do i=ithet_start,ithet_end
10337 c
10338 c     do i=1,nfrag_back
10339 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10340 c
10341 c Deviation of theta angles wrt constr_homology ref structures
10342 c
10343         utheta_i=0.0d0 ! argument of Gaussian for single k
10344         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10345 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10346 c       over residues in a fragment
10347 c       write (iout,*) "theta(",i,")=",theta(i)
10348         do k=1,constr_homology
10349 c
10350 c         dtheta_i=theta(j)-thetaref(j,iref)
10351 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10352           theta_diff(k)=thetatpl(k,i)-theta(i)
10353 c
10354           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10355 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10356           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10357           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10358 c         Gradient for single Gaussian restraint in subr Econstr_back
10359 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10360 c
10361         enddo
10362 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10363 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10364
10365 c
10366 #ifdef GRAD
10367 c         Gradient for multiple Gaussian restraint
10368         sum_gtheta=gutheta_i
10369         sum_sgtheta=0.0d0
10370         do k=1,constr_homology
10371 c        New generalized expr for multiple Gaussian from Econstr_back
10372          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10373 c
10374 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10375           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10376         enddo
10377 c
10378 c       Final value of gradient using same var as in Econstr_back
10379         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10380      &               *waga_homology(iset)
10381 c       dutheta(i)=sum_sgtheta/sum_gtheta
10382 c
10383 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10384 #endif
10385         Eval=Eval-dLOG(gutheta_i/constr_homology)
10386 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10387 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10388 c       Uconst_back=Uconst_back+utheta(i)
10389       enddo ! (i-loop for theta)
10390 #ifdef DEBUG
10391       write(iout,*) "------- theta restrs end -------"
10392 #endif
10393       endif
10394 c
10395 c Deviation of local SC geometry
10396 c
10397 c Separation of two i-loops (instructed by AL - 11/3/2014)
10398 c
10399 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10400 c     write (iout,*) "waga_d",waga_d
10401
10402 #ifdef DEBUG
10403       write(iout,*) "------- SC restrs start -------"
10404       write (iout,*) "Initial duscdiff,duscdiffx"
10405       do i=loc_start,loc_end
10406         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10407      &                 (duscdiffx(jik,i),jik=1,3)
10408       enddo
10409 #endif
10410       do i=loc_start,loc_end
10411         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10412         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10413 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10414 c       write(iout,*) "xxtab, yytab, zztab"
10415 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10416         do k=1,constr_homology
10417 c
10418           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10419 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10420           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10421           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10422 c         write(iout,*) "dxx, dyy, dzz"
10423 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10424 c
10425           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10426 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10427 c         uscdiffk(k)=usc_diff(i)
10428           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10429           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10430 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10431 c     &      xxref(j),yyref(j),zzref(j)
10432         enddo
10433 c
10434 c       Gradient
10435 c
10436 c       Generalized expression for multiple Gaussian acc to that for a single
10437 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10438 c
10439 c       Original implementation
10440 c       sum_guscdiff=guscdiff(i)
10441 c
10442 c       sum_sguscdiff=0.0d0
10443 c       do k=1,constr_homology
10444 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10445 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10446 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10447 c       enddo
10448 c
10449 c       Implementation of new expressions for gradient (Jan. 2015)
10450 c
10451 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10452 #ifdef GRAD
10453         do k=1,constr_homology
10454 c
10455 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10456 c       before. Now the drivatives should be correct
10457 c
10458           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10459 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10460           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10461           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10462 c
10463 c         New implementation
10464 c
10465           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10466      &                 sigma_d(k,i) ! for the grad wrt r'
10467 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10468 c
10469 c
10470 c        New implementation
10471          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10472          do jik=1,3
10473             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10474      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10475      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10476             duscdiff(jik,i)=duscdiff(jik,i)+
10477      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10478      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10479             duscdiffx(jik,i)=duscdiffx(jik,i)+
10480      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10481      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10482 c
10483 #ifdef DEBUG
10484              write(iout,*) "jik",jik,"i",i
10485              write(iout,*) "dxx, dyy, dzz"
10486              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10487              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10488 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10489 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10490 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10491 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10492 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10493 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10494 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10495 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10496 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10497 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10498 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10499 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10500 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10501 c            endif
10502 #endif
10503          enddo
10504         enddo
10505 #endif
10506 c
10507 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10508 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10509 c
10510 c        write (iout,*) i," uscdiff",uscdiff(i)
10511 c
10512 c Put together deviations from local geometry
10513
10514 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10515 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10516         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10517 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10518 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10519 c       Uconst_back=Uconst_back+usc_diff(i)
10520 c
10521 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10522 c
10523 c     New implment: multiplied by sum_sguscdiff
10524 c
10525
10526       enddo ! (i-loop for dscdiff)
10527
10528 c      endif
10529
10530 #ifdef DEBUG
10531       write(iout,*) "------- SC restrs end -------"
10532         write (iout,*) "------ After SC loop in e_modeller ------"
10533         do i=loc_start,loc_end
10534          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10535          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10536         enddo
10537       if (waga_theta.eq.1.0d0) then
10538       write (iout,*) "in e_modeller after SC restr end: dutheta"
10539       do i=ithet_start,ithet_end
10540         write (iout,*) i,dutheta(i)
10541       enddo
10542       endif
10543       if (waga_d.eq.1.0d0) then
10544       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10545       do i=1,nres
10546         write (iout,*) i,(duscdiff(j,i),j=1,3)
10547         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10548       enddo
10549       endif
10550 #endif
10551
10552 c Total energy from homology restraints
10553 #ifdef DEBUG
10554       write (iout,*) "odleg",odleg," kat",kat
10555       write (iout,*) "odleg",odleg," kat",kat
10556       write (iout,*) "Eval",Eval," Erot",Erot
10557       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10558       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10559       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10560 #endif
10561 c
10562 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10563 c
10564 c     ehomology_constr=odleg+kat
10565 c
10566 c     For Lorentzian-type Urestr
10567 c
10568
10569       if (waga_dist.ge.0.0d0) then
10570 c
10571 c          For Gaussian-type Urestr
10572 c
10573 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10574 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10575         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10576      &              waga_theta*Eval+waga_d*Erot
10577 c     write (iout,*) "ehomology_constr=",ehomology_constr
10578       else
10579 c
10580 c          For Lorentzian-type Urestr
10581 c
10582 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10583 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10584         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10585      &              waga_theta*Eval+waga_d*Erot
10586 c     write (iout,*) "ehomology_constr=",ehomology_constr
10587       endif
10588 #ifdef DEBUG
10589       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10590      & "Eval",waga_theta,eval,
10591      &   "Erot",waga_d,Erot
10592       write (iout,*) "ehomology_constr",ehomology_constr
10593 #endif
10594       return
10595
10596   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10597   747 format(a12,i4,i4,i4,f8.3,f8.3)
10598   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10599   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10600   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10601      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10602       end