source/cluster/wham/src-M-SAXS-homology/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       else
 134         eliptran=0.0d0
 135       endif
 136 #ifdef FOURBODY
 137 C
 138 C 12/1/95 Multi-body terms
 139 C
 140       n_corr=0
 141       n_corr1=0
 142       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 143      &    .or. wturn6.gt.0.0d0) then
 144 c         write(iout,*)"calling multibody_eello"
 145          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 146 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 147 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 148       else
 149          ecorr=0.0d0
 150          ecorr5=0.0d0
 151          ecorr6=0.0d0
 152          eturn6=0.0d0
 153       endif
 154       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 155 c         write (iout,*) "Calling multibody_hbond"
 156          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 157       endif
 158 #endif
 159 c      write (iout,*) "NSAXS",nsaxs
 160       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 161         call e_saxs(Esaxs_constr)
 162 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 163       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 164         call e_saxsC(Esaxs_constr)
 165 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 166       else
 167         Esaxs_constr = 0.0d0
 168       endif
 169 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 170       if (constr_homology.ge.1) then
 171         call e_modeller(ehomology_constr)
 172       else
 173         ehomology_constr=0.0d0
 174       endif
 175
 176 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 177 #ifdef DFA
 178 C     BARTEK for dfa test!
 179       if (wdfa_dist.gt.0) call edfad(edfadis)
 180 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 181       if (wdfa_tor.gt.0) call edfat(edfator)
 182 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 183       if (wdfa_nei.gt.0) call edfan(edfanei)
 184 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 185       if (wdfa_beta.gt.0) call edfab(edfabet)
 186 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 187 #endif
 188
 189 #ifdef SPLITELE
 190       if (shield_mode.gt.0) then
 191       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 192      & +welec*fact(1)*ees
 193      & +fact(1)*wvdwpp*evdw1
 194      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 195      & +wstrain*ehpb
 196      & +wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 197      & +wcorr6*fact(5)*ecorr6
 198      & +wturn4*fact(3)*eello_turn4
 199      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 200      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 201      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 202      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 203      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 204      & +wdfa_beta*edfabet
 205       else
 206       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 207      & +wvdwpp*evdw1
 208      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 209      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 210      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 211      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 212      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 213      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 214      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 215      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 216      & +wdfa_beta*edfabet
 217       endif
 218 #else
 219       if (shield_mode.gt.0) then
 220       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 221      & +welec*fact(1)*(ees+evdw1)
 222      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 223      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 224      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 225      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 226      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 227      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 228      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 229      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 230      & +wdfa_beta*edfabet
 231       else
 232       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 233      & +welec*fact(1)*(ees+evdw1)
 234      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 235      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 236      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 237      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 238      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 239      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 240      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 241      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 242      & +wdfa_beta*edfabet
 243       endif
 244 #endif
 245       energia(0)=etot
 246       energia(1)=evdw
 247 #ifdef SCP14
 248       energia(2)=evdw2-evdw2_14
 249       energia(17)=evdw2_14
 250 #else
 251       energia(2)=evdw2
 252       energia(17)=0.0d0
 253 #endif
 254 #ifdef SPLITELE
 255       energia(3)=ees
 256       energia(16)=evdw1
 257 #else
 258       energia(3)=ees+evdw1
 259       energia(16)=0.0d0
 260 #endif
 261       energia(4)=ecorr
 262       energia(5)=ecorr5
 263       energia(6)=ecorr6
 264       energia(7)=eel_loc
 265       energia(8)=eello_turn3
 266       energia(9)=eello_turn4
 267       energia(10)=eturn6
 268       energia(11)=ebe
 269       energia(12)=escloc
 270       energia(13)=etors
 271       energia(14)=etors_d
 272       energia(15)=ehpb
 273       energia(18)=estr
 274       energia(19)=esccor
 275       energia(20)=edihcnstr
 276       energia(21)=evdw_t
 277       energia(22)=eliptran
 278       energia(24)=ethetacnstr
 279       energia(26)=esaxs_constr
 280       energia(27)=ehomology_constr
 281       energia(28)=edfadis
 282       energia(29)=edfator
 283       energia(30)=edfanei
 284       energia(31)=edfabet
 285 c detecting NaNQ
 286 #ifdef ISNAN
 287 #ifdef AIX
 288       if (isnan(etot).ne.0) energia(0)=1.0d+99
 289 #else
 290       if (isnan(etot)) energia(0)=1.0d+99
 291 #endif
 292 #else
 293       i=0
 294 #ifdef WINPGI
 295       idumm=proc_proc(etot,i)
 296 #else
 297       call proc_proc(etot,i)
 298 #endif
 299       if(i.eq.1)energia(0)=1.0d+99
 300 #endif
 301 #ifdef MPL
 302 c     endif
 303 #endif
 304 #ifdef DEBUG
 305       call enerprint(energia,fact)
 306 #endif
 307       if (calc_grad) then
 308 C
 309 C Sum up the components of the Cartesian gradient.
 310 C
 311 #ifdef SPLITELE
 312       do i=1,nct
 313         do j=1,3
 314       if (shield_mode.eq.0) then
 315           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 316      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 317      &                wbond*gradb(j,i)+
 318      &                wstrain*ghpbc(j,i)+
 319      &                wcorr*fact(3)*gradcorr(j,i)+
 320      &                wel_loc*fact(2)*gel_loc(j,i)+
 321      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 322      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 323      &                wcorr5*fact(4)*gradcorr5(j,i)+
 324      &                wcorr6*fact(5)*gradcorr6(j,i)+
 325      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 326      &                wsccor*fact(2)*gsccorc(j,i)
 327      &               +wliptran*gliptranc(j,i)+
 328      &                wdfa_dist*gdfad(j,i)+
 329      &                wdfa_tor*gdfat(j,i)+
 330      &                wdfa_nei*gdfan(j,i)+
 331      &                wdfa_beta*gdfab(j,i)
 332           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 333      &                  wbond*gradbx(j,i)+
 334      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 335      &                  wsccor*fact(2)*gsccorx(j,i)
 336      &                 +wliptran*gliptranx(j,i)
 337         else
 338           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 339      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 340      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 341      &                wbond*gradb(j,i)+
 342      &                wstrain*ghpbc(j,i)+
 343      &                wcorr*fact(3)*gradcorr(j,i)+
 344      &                wel_loc*fact(2)*gel_loc(j,i)+
 345      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 346      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 347      &                wcorr5*fact(4)*gradcorr5(j,i)+
 348      &                wcorr6*fact(5)*gradcorr6(j,i)+
 349      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 350      &                wsccor*fact(2)*gsccorc(j,i)
 351      &               +wliptran*gliptranc(j,i)
 352      &                 +welec*gshieldc(j,i)
 353      &                 +welec*gshieldc_loc(j,i)
 354      &                 +wcorr*gshieldc_ec(j,i)
 355      &                 +wcorr*gshieldc_loc_ec(j,i)
 356      &                 +wturn3*gshieldc_t3(j,i)
 357      &                 +wturn3*gshieldc_loc_t3(j,i)
 358      &                 +wturn4*gshieldc_t4(j,i)
 359      &                 +wturn4*gshieldc_loc_t4(j,i)
 360      &                 +wel_loc*gshieldc_ll(j,i)
 361      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 362      &                wdfa_dist*gdfad(j,i)+
 363      &                wdfa_tor*gdfat(j,i)+
 364      &                wdfa_nei*gdfan(j,i)+
 365      &                wdfa_beta*gdfab(j,i)
 366           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 367      &                 +fact(1)*wscp*gradx_scp(j,i)+
 368      &                  wbond*gradbx(j,i)+
 369      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 370      &                  wsccor*fact(2)*gsccorx(j,i)
 371      &                 +wliptran*gliptranx(j,i)
 372      &                 +welec*gshieldx(j,i)
 373      &                 +wcorr*gshieldx_ec(j,i)
 374      &                 +wturn3*gshieldx_t3(j,i)
 375      &                 +wturn4*gshieldx_t4(j,i)
 376      &                 +wel_loc*gshieldx_ll(j,i)
 377
 378
 379         endif
 380         enddo
 381 #else
 382       do i=1,nct
 383         do j=1,3
 384                 if (shield_mode.eq.0) then
 385           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 386      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 387      &                wbond*gradb(j,i)+
 388      &                wcorr*fact(3)*gradcorr(j,i)+
 389      &                wel_loc*fact(2)*gel_loc(j,i)+
 390      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 391      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 392      &                wcorr5*fact(4)*gradcorr5(j,i)+
 393      &                wcorr6*fact(5)*gradcorr6(j,i)+
 394      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 395      &                wsccor*fact(2)*gsccorc(j,i)
 396      &               +wliptran*gliptranc(j,i)+
 397      &                wdfa_dist*gdfad(j,i)+
 398      &                wdfa_tor*gdfat(j,i)+
 399      &                wdfa_nei*gdfan(j,i)+
 400      &                wdfa_beta*gdfab(j,i)
 401           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 402      &                  wbond*gradbx(j,i)+
 403      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 404      &                  wsccor*fact(1)*gsccorx(j,i)
 405      &                 +wliptran*gliptranx(j,i)
 406               else
 407           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 408      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 409      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 410      &                wbond*gradb(j,i)+
 411      &                wcorr*fact(3)*gradcorr(j,i)+
 412      &                wel_loc*fact(2)*gel_loc(j,i)+
 413      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 414      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 415      &                wcorr5*fact(4)*gradcorr5(j,i)+
 416      &                wcorr6*fact(5)*gradcorr6(j,i)+
 417      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 418      &                wsccor*fact(2)*gsccorc(j,i)
 419      &               +wliptran*gliptranc(j,i)
 420      &                 +welec*gshieldc(j,i)
 421      &                 +welec*gshieldc_loc(j,i)
 422      &                 +wcorr*gshieldc_ec(j,i)
 423      &                 +wcorr*gshieldc_loc_ec(j,i)
 424      &                 +wturn3*gshieldc_t3(j,i)
 425      &                 +wturn3*gshieldc_loc_t3(j,i)
 426      &                 +wturn4*gshieldc_t4(j,i)
 427      &                 +wturn4*gshieldc_loc_t4(j,i)
 428      &                 +wel_loc*gshieldc_ll(j,i)
 429      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 430      &                wdfa_dist*gdfad(j,i)+
 431      &                wdfa_tor*gdfat(j,i)+
 432      &                wdfa_nei*gdfan(j,i)+
 433      &                wdfa_beta*gdfab(j,i)
 434           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 435      &                  fact(1)*wscp*gradx_scp(j,i)+
 436      &                  wbond*gradbx(j,i)+
 437      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 438      &                  wsccor*fact(1)*gsccorx(j,i)
 439      &                 +wliptran*gliptranx(j,i)
 440      &                 +welec*gshieldx(j,i)
 441      &                 +wcorr*gshieldx_ec(j,i)
 442      &                 +wturn3*gshieldx_t3(j,i)
 443      &                 +wturn4*gshieldx_t4(j,i)
 444      &                 +wel_loc*gshieldx_ll(j,i)
 445          endif
 446         enddo
 447 #endif
 448       enddo
 449
 450
 451       do i=1,nres-3
 452         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 453      &   +wcorr5*fact(4)*g_corr5_loc(i)
 454      &   +wcorr6*fact(5)*g_corr6_loc(i)
 455      &   +wturn4*fact(3)*gel_loc_turn4(i)
 456      &   +wturn3*fact(2)*gel_loc_turn3(i)
 457      &   +wturn6*fact(5)*gel_loc_turn6(i)
 458      &   +wel_loc*fact(2)*gel_loc_loc(i)
 459 c     &   +wsccor*fact(1)*gsccor_loc(i)
 460 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 461       enddo
 462       endif
 463       if (dyn_ss) call dyn_set_nss
 464       return
 465       end
 466 C------------------------------------------------------------------------
 467       subroutine enerprint(energia,fact)
 468       implicit real*8 (a-h,o-z)
 469       include 'DIMENSIONS'
 470       include 'COMMON.IOUNITS'
 471       include 'COMMON.FFIELD'
 472       include 'COMMON.SBRIDGE'
 473       include 'COMMON.CONTROL'
 474       double precision energia(0:max_ene),fact(6)
 475       etot=energia(0)
 476       evdw=energia(1)+fact(6)*energia(21)
 477 #ifdef SCP14
 478       evdw2=energia(2)+energia(17)
 479 #else
 480       evdw2=energia(2)
 481 #endif
 482       ees=energia(3)
 483 #ifdef SPLITELE
 484       evdw1=energia(16)
 485 #endif
 486       ecorr=energia(4)
 487       ecorr5=energia(5)
 488       ecorr6=energia(6)
 489       eel_loc=energia(7)
 490       eello_turn3=energia(8)
 491       eello_turn4=energia(9)
 492       eello_turn6=energia(10)
 493       ebe=energia(11)
 494       escloc=energia(12)
 495       etors=energia(13)
 496       etors_d=energia(14)
 497       ehpb=energia(15)
 498       esccor=energia(19)
 499       edihcnstr=energia(20)
 500       estr=energia(18)
 501       ethetacnstr=energia(24)
 502       eliptran=energia(22)
 503       esaxs=energia(26)
 504       ehomology_constr=energia(27)
 505 C     Bartek
 506       edfadis = energia(28)
 507       edfator = energia(29)
 508       edfanei = energia(30)
 509       edfabet = energia(31)
 510 #ifdef SPLITELE
 511       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 512      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 513      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 514 #ifdef FOURBODY
 515      &  ecorr,wcorr*fact(3),
 516      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 517 #endif
 518      &  eel_loc,
 519      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 520      &  eello_turn4,wturn4*fact(3),
 521 #ifdef FOURBODY
 522      &  eello_turn6,wturn6*fact(5),
 523 #endif
 524      &  esccor,wsccor*fact(1),edihcnstr,
 525      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 526      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 527      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 528      &  edfabet,wdfa_beta,
 529      &  etot
 530    10 format (/'Virtual-chain energies:'//
 531      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 532      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 533      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 534      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 535      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 536      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 537      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 538      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 539      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 540      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 541      & ' (SS bridges & dist. cnstr.)'/
 542 #ifdef FOURBODY
 543      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 544      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 545      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 546 #endif
 547      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 548      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 549      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 550 #ifdef FOURBODY
 551      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 552 #endif
 553      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 554      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 555      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 556      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 557      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 558      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 559      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 560      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 561      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 562      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 563      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 564      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 565      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 566      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 567      & 'ETOT=  ',1pE16.6,' (total)')
 568
 569 #else
 570       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 571      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 572      &  etors_d,wtor_d*fact(2),ehpb,
 573 #ifdef FOURBODY
 574      &  wstrain,ecorr,wcorr*fact(3),
 575      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 576 #endif
 577      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 578      &  eello_turn4,wturn4*fact(3),
 579 #ifdef FOURBODY
 580      &  eello_turn6,wturn6*fact(5),
 581 #endif
 582      &  esccor,wsccor*fact(1),edihcnstr,
 583      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 584      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 585      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 586      &  edfabet,wdfa_beta,
 587      &  etot
 588    10 format (/'Virtual-chain energies:'//
 589      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 590      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 591      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 592      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 593      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 594      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 595      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 596      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 597      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 598      & ' (SS bridges & dist. restr.)'/
 599 #ifdef FOURBODY
 600      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 601      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 602      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 603 #endif
 604      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 605      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 606      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 607 #ifdef FOURBODY
 608      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 609 #endif
 610      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 611      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 612      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 613      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 614      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 615      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 616      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 617      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 618      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 619      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 620      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 621      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 622      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 623      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 624      & 'ETOT=  ',1pE16.6,' (total)')
 625 #endif
 626       return
 627       end
 628 C-----------------------------------------------------------------------
 629       subroutine elj(evdw,evdw_t)
 630 C
 631 C This subroutine calculates the interaction energy of nonbonded side chains
 632 C assuming the LJ potential of interaction.
 633 C
 634       implicit real*8 (a-h,o-z)
 635       include 'DIMENSIONS'
 636       include "DIMENSIONS.COMPAR"
 637       parameter (accur=1.0d-10)
 638       include 'COMMON.GEO'
 639       include 'COMMON.VAR'
 640       include 'COMMON.LOCAL'
 641       include 'COMMON.CHAIN'
 642       include 'COMMON.DERIV'
 643       include 'COMMON.INTERACT'
 644       include 'COMMON.TORSION'
 645       include 'COMMON.SBRIDGE'
 646       include 'COMMON.NAMES'
 647       include 'COMMON.IOUNITS'
 648 #ifdef FOURBODY
 649       include 'COMMON.CONTACTS'
 650       include 'COMMON.CONTMAT'
 651 #endif
 652       dimension gg(3)
 653       integer icant
 654       external icant
 655 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 656 c ROZNICA z cluster
 657 c      do i=1,210
 658 c        do j=1,2
 659 c          eneps_temp(j,i)=0.0d0
 660 c        enddo
 661 c      enddo
 662 cROZNICA
 663
 664       evdw=0.0D0
 665       evdw_t=0.0d0
 666       do i=iatsc_s,iatsc_e
 667         itypi=iabs(itype(i))
 668         if (itypi.eq.ntyp1) cycle
 669         itypi1=iabs(itype(i+1))
 670         xi=c(1,nres+i)
 671         yi=c(2,nres+i)
 672         zi=c(3,nres+i)
 673 C Change 12/1/95
 674         num_conti=0
 675 C
 676 C Calculate SC interaction energy.
 677 C
 678         do iint=1,nint_gr(i)
 679 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 680 cd   &                  'iend=',iend(i,iint)
 681           do j=istart(i,iint),iend(i,iint)
 682             itypj=iabs(itype(j))
 683             if (itypj.eq.ntyp1) cycle
 684             xj=c(1,nres+j)-xi
 685             yj=c(2,nres+j)-yi
 686             zj=c(3,nres+j)-zi
 687 C Change 12/1/95 to calculate four-body interactions
 688             rij=xj*xj+yj*yj+zj*zj
 689             rrij=1.0D0/rij
 690             sqrij=dsqrt(rij)
 691             sss1=sscale(sqrij)
 692             if (sss1.eq.0.0d0) cycle
 693             sssgrad1=sscagrad(sqrij)
 694 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 695             eps0ij=eps(itypi,itypj)
 696             fac=rrij**expon2
 697             e1=fac*fac*aa
 698             e2=fac*bb
 699             evdwij=e1+e2
 700             ij=icant(itypi,itypj)
 701 c ROZNICA z cluster
 702 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 703 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 704 c
 705
 706 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 707 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 708 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 709 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 710 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 711 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 712             if (bb.gt.0.0d0) then
 713               evdw=evdw+sss1*evdwij
 714             else
 715               evdw_t=evdw_t+sss1*evdwij
 716             endif
 717             if (calc_grad) then
 718 C
 719 C Calculate the components of the gradient in DC and X
 720 C
 721             fac=-rrij*(e1+evdwij)*sss1
 722      &          +evdwij*sssgrad1/sqrij/expon
 723             gg(1)=xj*fac
 724             gg(2)=yj*fac
 725             gg(3)=zj*fac
 726             do k=1,3
 727               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 728               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 729             enddo
 730             do k=i,j-1
 731               do l=1,3
 732                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 733               enddo
 734             enddo
 735             endif
 736 #ifdef FOURBODY
 737 C
 738 C 12/1/95, revised on 5/20/97
 739 C
 740 C Calculate the contact function. The ith column of the array JCONT will
 741 C contain the numbers of atoms that make contacts with the atom I (of numbers
 742 C greater than I). The arrays FACONT and GACONT will contain the values of
 743 C the contact function and its derivative.
 744 C
 745 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 746 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 747 C Uncomment next line, if the correlation interactions are contact function only
 748             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 749               rij=dsqrt(rij)
 750               sigij=sigma(itypi,itypj)
 751               r0ij=rs0(itypi,itypj)
 752 C
 753 C Check whether the SC's are not too far to make a contact.
 754 C
 755               rcut=1.5d0*r0ij
 756               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 757 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 758 C
 759               if (fcont.gt.0.0D0) then
 760 C If the SC-SC distance if close to sigma, apply spline.
 761 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 762 cAdam &             fcont1,fprimcont1)
 763 cAdam           fcont1=1.0d0-fcont1
 764 cAdam           if (fcont1.gt.0.0d0) then
 765 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 766 cAdam             fcont=fcont*fcont1
 767 cAdam           endif
 768 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 769 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 770 cga             do k=1,3
 771 cga               gg(k)=gg(k)*eps0ij
 772 cga             enddo
 773 cga             eps0ij=-evdwij*eps0ij
 774 C Uncomment for AL's type of SC correlation interactions.
 775 cadam           eps0ij=-evdwij
 776                 num_conti=num_conti+1
 777                 jcont(num_conti,i)=j
 778                 facont(num_conti,i)=fcont*eps0ij
 779                 fprimcont=eps0ij*fprimcont/rij
 780                 fcont=expon*fcont
 781 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 782 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 783 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 784 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 785                 gacont(1,num_conti,i)=-fprimcont*xj
 786                 gacont(2,num_conti,i)=-fprimcont*yj
 787                 gacont(3,num_conti,i)=-fprimcont*zj
 788 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 789 cd              write (iout,'(2i3,3f10.5)')
 790 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 791               endif
 792             endif
 793 #endif
 794           enddo      ! j
 795         enddo        ! iint
 796 #ifdef FOURBODY
 797 C Change 12/1/95
 798         num_cont(i)=num_conti
 799 #endif
 800       enddo          ! i
 801       if (calc_grad) then
 802       do i=1,nct
 803         do j=1,3
 804           gvdwc(j,i)=expon*gvdwc(j,i)
 805           gvdwx(j,i)=expon*gvdwx(j,i)
 806         enddo
 807       enddo
 808       endif
 809 C******************************************************************************
 810 C
 811 C                              N O T E !!!
 812 C
 813 C To save time, the factor of EXPON has been extracted from ALL components
 814 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 815 C use!
 816 C
 817 C******************************************************************************
 818       return
 819       end
 820 C-----------------------------------------------------------------------------
 821       subroutine eljk(evdw,evdw_t)
 822 C
 823 C This subroutine calculates the interaction energy of nonbonded side chains
 824 C assuming the LJK potential of interaction.
 825 C
 826       implicit real*8 (a-h,o-z)
 827       include 'DIMENSIONS'
 828       include "DIMENSIONS.COMPAR"
 829       include 'COMMON.GEO'
 830       include 'COMMON.VAR'
 831       include 'COMMON.LOCAL'
 832       include 'COMMON.CHAIN'
 833       include 'COMMON.DERIV'
 834       include 'COMMON.INTERACT'
 835       include 'COMMON.IOUNITS'
 836       include 'COMMON.NAMES'
 837       dimension gg(3)
 838       logical scheck
 839       integer icant
 840       external icant
 841 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 842 c      do i=1,210
 843 c        do j=1,2
 844 c          eneps_temp(j,i)=0.0d0
 845 c        enddo
 846 c      enddo
 847       evdw=0.0D0
 848       evdw_t=0.0d0
 849       do i=iatsc_s,iatsc_e
 850         itypi=iabs(itype(i))
 851         if (itypi.eq.ntyp1) cycle
 852         itypi1=iabs(itype(i+1))
 853         xi=c(1,nres+i)
 854         yi=c(2,nres+i)
 855         zi=c(3,nres+i)
 856 C
 857 C Calculate SC interaction energy.
 858 C
 859         do iint=1,nint_gr(i)
 860           do j=istart(i,iint),iend(i,iint)
 861             itypj=iabs(itype(j))
 862             if (itypj.eq.ntyp1) cycle
 863             xj=c(1,nres+j)-xi
 864             yj=c(2,nres+j)-yi
 865             zj=c(3,nres+j)-zi
 866             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 867             fac_augm=rrij**expon
 868             e_augm=augm(itypi,itypj)*fac_augm
 869             r_inv_ij=dsqrt(rrij)
 870             rij=1.0D0/r_inv_ij
 871             sss1=sscale(rij)
 872             if (sss1.eq.0.0d0) cycle
 873             sssgrad1=sscagrad(rij)
 874             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 875             fac=r_shift_inv**expon
 876             e1=fac*fac*aa
 877             e2=fac*bb
 878             evdwij=e_augm+e1+e2
 879             ij=icant(itypi,itypj)
 880 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 881 c     &        /dabs(eps(itypi,itypj))
 882 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 883 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 884 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 885 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 886 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 887 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 888 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 889 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 890             if (bb.gt.0.0d0) then
 891               evdw=evdw+evdwij*sss1
 892             else
 893               evdw_t=evdw_t+evdwij*sss1
 894             endif
 895             if (calc_grad) then
 896 C
 897 C Calculate the components of the gradient in DC and X
 898 C
 899            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 900      &          +evdwij*sssgrad1*r_inv_ij/expon
 901             gg(1)=xj*fac
 902             gg(2)=yj*fac
 903             gg(3)=zj*fac
 904             do k=1,3
 905               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 906               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 907             enddo
 908             do k=i,j-1
 909               do l=1,3
 910                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 911               enddo
 912             enddo
 913             endif
 914           enddo      ! j
 915         enddo        ! iint
 916       enddo          ! i
 917       if (calc_grad) then
 918       do i=1,nct
 919         do j=1,3
 920           gvdwc(j,i)=expon*gvdwc(j,i)
 921           gvdwx(j,i)=expon*gvdwx(j,i)
 922         enddo
 923       enddo
 924       endif
 925       return
 926       end
 927 C-----------------------------------------------------------------------------
 928       subroutine ebp(evdw,evdw_t)
 929 C
 930 C This subroutine calculates the interaction energy of nonbonded side chains
 931 C assuming the Berne-Pechukas potential of interaction.
 932 C
 933       implicit real*8 (a-h,o-z)
 934       include 'DIMENSIONS'
 935       include "DIMENSIONS.COMPAR"
 936       include 'COMMON.GEO'
 937       include 'COMMON.VAR'
 938       include 'COMMON.LOCAL'
 939       include 'COMMON.CHAIN'
 940       include 'COMMON.DERIV'
 941       include 'COMMON.NAMES'
 942       include 'COMMON.INTERACT'
 943       include 'COMMON.IOUNITS'
 944       include 'COMMON.CALC'
 945       common /srutu/ icall
 946 c     double precision rrsave(maxdim)
 947       logical lprn
 948       integer icant
 949       external icant
 950 c      do i=1,210
 951 c        do j=1,2
 952 c          eneps_temp(j,i)=0.0d0
 953 c        enddo
 954 c      enddo
 955       evdw=0.0D0
 956       evdw_t=0.0d0
 957 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 958 c     if (icall.eq.0) then
 959 c       lprn=.true.
 960 c     else
 961         lprn=.false.
 962 c     endif
 963       ind=0
 964       do i=iatsc_s,iatsc_e
 965         itypi=iabs(itype(i))
 966         if (itypi.eq.ntyp1) cycle
 967         itypi1=iabs(itype(i+1))
 968         xi=c(1,nres+i)
 969         yi=c(2,nres+i)
 970         zi=c(3,nres+i)
 971         dxi=dc_norm(1,nres+i)
 972         dyi=dc_norm(2,nres+i)
 973         dzi=dc_norm(3,nres+i)
 974         dsci_inv=vbld_inv(i+nres)
 975 C
 976 C Calculate SC interaction energy.
 977 C
 978         do iint=1,nint_gr(i)
 979           do j=istart(i,iint),iend(i,iint)
 980             ind=ind+1
 981             itypj=iabs(itype(j))
 982             if (itypj.eq.ntyp1) cycle
 983             dscj_inv=vbld_inv(j+nres)
 984             chi1=chi(itypi,itypj)
 985             chi2=chi(itypj,itypi)
 986             chi12=chi1*chi2
 987             chip1=chip(itypi)
 988             chip2=chip(itypj)
 989             chip12=chip1*chip2
 990             alf1=alp(itypi)
 991             alf2=alp(itypj)
 992             alf12=0.5D0*(alf1+alf2)
 993 C For diagnostics only!!!
 994 c           chi1=0.0D0
 995 c           chi2=0.0D0
 996 c           chi12=0.0D0
 997 c           chip1=0.0D0
 998 c           chip2=0.0D0
 999 c           chip12=0.0D0
1000 c           alf1=0.0D0
1001 c           alf2=0.0D0
1002 c           alf12=0.0D0
1003             xj=c(1,nres+j)-xi
1004             yj=c(2,nres+j)-yi
1005             zj=c(3,nres+j)-zi
1006             dxj=dc_norm(1,nres+j)
1007             dyj=dc_norm(2,nres+j)
1008             dzj=dc_norm(3,nres+j)
1009             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1010 cd          if (icall.eq.0) then
1011 cd            rrsave(ind)=rrij
1012 cd          else
1013 cd            rrij=rrsave(ind)
1014 cd          endif
1015             rij=dsqrt(rrij)
1016 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1017             call sc_angular
1018 C Calculate whole angle-dependent part of epsilon and contributions
1019 C to its derivatives
1020             fac=(rrij*sigsq)**expon2
1021             e1=fac*fac*aa
1022             e2=fac*bb
1023             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1024             eps2der=evdwij*eps3rt
1025             eps3der=evdwij*eps2rt
1026             evdwij=evdwij*eps2rt*eps3rt
1027             ij=icant(itypi,itypj)
1028             aux=eps1*eps2rt**2*eps3rt**2
1029 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1030 c     &        /dabs(eps(itypi,itypj))
1031 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1032             if (bb.gt.0.0d0) then
1033               evdw=evdw+evdwij
1034             else
1035               evdw_t=evdw_t+evdwij
1036             endif
1037             if (calc_grad) then
1038             if (lprn) then
1039             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1040             epsi=bb**2/aa
1041             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1042      &        restyp(itypi),i,restyp(itypj),j,
1043      &        epsi,sigm,chi1,chi2,chip1,chip2,
1044      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1045      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1046      &        evdwij
1047             endif
1048 C Calculate gradient components.
1049             e1=e1*eps1*eps2rt**2*eps3rt**2
1050             fac=-expon*(e1+evdwij)
1051             sigder=fac/sigsq
1052             fac=rrij*fac
1053 C Calculate radial part of the gradient
1054             gg(1)=xj*fac
1055             gg(2)=yj*fac
1056             gg(3)=zj*fac
1057 C Calculate the angular part of the gradient and sum add the contributions
1058 C to the appropriate components of the Cartesian gradient.
1059             call sc_grad
1060             endif
1061           enddo      ! j
1062         enddo        ! iint
1063       enddo          ! i
1064 c     stop
1065       return
1066       end
1067 C-----------------------------------------------------------------------------
1068       subroutine egb(evdw,evdw_t)
1069 C
1070 C This subroutine calculates the interaction energy of nonbonded side chains
1071 C assuming the Gay-Berne potential of interaction.
1072 C
1073       implicit real*8 (a-h,o-z)
1074       include 'DIMENSIONS'
1075       include "DIMENSIONS.COMPAR"
1076       include 'COMMON.GEO'
1077       include 'COMMON.VAR'
1078       include 'COMMON.LOCAL'
1079       include 'COMMON.CHAIN'
1080       include 'COMMON.DERIV'
1081       include 'COMMON.NAMES'
1082       include 'COMMON.INTERACT'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CALC'
1085       include 'COMMON.SBRIDGE'
1086       logical lprn
1087       common /srutu/icall
1088       integer icant,xshift,yshift,zshift
1089       external icant
1090 c      do i=1,210
1091 c        do j=1,2
1092 c          eneps_temp(j,i)=0.0d0
1093 c        enddo
1094 c      enddo
1095 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1096       evdw=0.0D0
1097       evdw_t=0.0d0
1098       lprn=.false.
1099 c      if (icall.gt.0) lprn=.true.
1100       ind=0
1101       do i=iatsc_s,iatsc_e
1102         itypi=iabs(itype(i))
1103         if (itypi.eq.ntyp1) cycle
1104         itypi1=iabs(itype(i+1))
1105         xi=c(1,nres+i)
1106         yi=c(2,nres+i)
1107         zi=c(3,nres+i)
1108 C returning the ith atom to box
1109           xi=mod(xi,boxxsize)
1110           if (xi.lt.0) xi=xi+boxxsize
1111           yi=mod(yi,boxysize)
1112           if (yi.lt.0) yi=yi+boxysize
1113           zi=mod(zi,boxzsize)
1114           if (zi.lt.0) zi=zi+boxzsize
1115        if ((zi.gt.bordlipbot)
1116      &.and.(zi.lt.bordliptop)) then
1117 C the energy transfer exist
1118         if (zi.lt.buflipbot) then
1119 C what fraction I am in
1120          fracinbuf=1.0d0-
1121      &        ((zi-bordlipbot)/lipbufthick)
1122 C lipbufthick is thickenes of lipid buffore
1123          sslipi=sscalelip(fracinbuf)
1124          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1125         elseif (zi.gt.bufliptop) then
1126          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1127          sslipi=sscalelip(fracinbuf)
1128          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1129         else
1130          sslipi=1.0d0
1131          ssgradlipi=0.0
1132         endif
1133        else
1134          sslipi=0.0d0
1135          ssgradlipi=0.0
1136        endif
1137
1138         dxi=dc_norm(1,nres+i)
1139         dyi=dc_norm(2,nres+i)
1140         dzi=dc_norm(3,nres+i)
1141         dsci_inv=vbld_inv(i+nres)
1142 C
1143 C Calculate SC interaction energy.
1144 C
1145         do iint=1,nint_gr(i)
1146           do j=istart(i,iint),iend(i,iint)
1147             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1148               call dyn_ssbond_ene(i,j,evdwij)
1149               evdw=evdw+evdwij
1150 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1151 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1152 C triple bond artifac removal
1153              do k=j+1,iend(i,iint)
1154 C search over all next residues
1155               if (dyn_ss_mask(k)) then
1156 C check if they are cysteins
1157 C              write(iout,*) 'k=',k
1158               call triple_ssbond_ene(i,j,k,evdwij)
1159 C call the energy function that removes the artifical triple disulfide
1160 C bond the soubroutine is located in ssMD.F
1161               evdw=evdw+evdwij
1162 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1163 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1164               endif!dyn_ss_mask(k)
1165              enddo! k
1166             ELSE
1167             ind=ind+1
1168             itypj=iabs(itype(j))
1169             if (itypj.eq.ntyp1) cycle
1170             dscj_inv=vbld_inv(j+nres)
1171             sig0ij=sigma(itypi,itypj)
1172             chi1=chi(itypi,itypj)
1173             chi2=chi(itypj,itypi)
1174             chi12=chi1*chi2
1175             chip1=chip(itypi)
1176             chip2=chip(itypj)
1177             chip12=chip1*chip2
1178             alf1=alp(itypi)
1179             alf2=alp(itypj)
1180             alf12=0.5D0*(alf1+alf2)
1181 C For diagnostics only!!!
1182 c           chi1=0.0D0
1183 c           chi2=0.0D0
1184 c           chi12=0.0D0
1185 c           chip1=0.0D0
1186 c           chip2=0.0D0
1187 c           chip12=0.0D0
1188 c           alf1=0.0D0
1189 c           alf2=0.0D0
1190 c           alf12=0.0D0
1191             xj=c(1,nres+j)
1192             yj=c(2,nres+j)
1193             zj=c(3,nres+j)
1194 C returning jth atom to box
1195           xj=mod(xj,boxxsize)
1196           if (xj.lt.0) xj=xj+boxxsize
1197           yj=mod(yj,boxysize)
1198           if (yj.lt.0) yj=yj+boxysize
1199           zj=mod(zj,boxzsize)
1200           if (zj.lt.0) zj=zj+boxzsize
1201        if ((zj.gt.bordlipbot)
1202      &.and.(zj.lt.bordliptop)) then
1203 C the energy transfer exist
1204         if (zj.lt.buflipbot) then
1205 C what fraction I am in
1206          fracinbuf=1.0d0-
1207      &        ((zj-bordlipbot)/lipbufthick)
1208 C lipbufthick is thickenes of lipid buffore
1209          sslipj=sscalelip(fracinbuf)
1210          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1211         elseif (zj.gt.bufliptop) then
1212          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1213          sslipj=sscalelip(fracinbuf)
1214          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1215         else
1216          sslipj=1.0d0
1217          ssgradlipj=0.0
1218         endif
1219        else
1220          sslipj=0.0d0
1221          ssgradlipj=0.0
1222        endif
1223       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1224      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1225       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1226      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1227 C       if (aa.ne.aa_aq(itypi,itypj)) then
1228
1229 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1230 C     & bb_aq(itypi,itypj)-bb,
1231 C     & sslipi,sslipj
1232 C         endif
1233
1234 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1235 C checking the distance
1236       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1237       xj_safe=xj
1238       yj_safe=yj
1239       zj_safe=zj
1240       subchap=0
1241 C finding the closest
1242       do xshift=-1,1
1243       do yshift=-1,1
1244       do zshift=-1,1
1245           xj=xj_safe+xshift*boxxsize
1246           yj=yj_safe+yshift*boxysize
1247           zj=zj_safe+zshift*boxzsize
1248           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1249           if(dist_temp.lt.dist_init) then
1250             dist_init=dist_temp
1251             xj_temp=xj
1252             yj_temp=yj
1253             zj_temp=zj
1254             subchap=1
1255           endif
1256        enddo
1257        enddo
1258        enddo
1259        if (subchap.eq.1) then
1260           xj=xj_temp-xi
1261           yj=yj_temp-yi
1262           zj=zj_temp-zi
1263        else
1264           xj=xj_safe-xi
1265           yj=yj_safe-yi
1266           zj=zj_safe-zi
1267        endif
1268
1269             dxj=dc_norm(1,nres+j)
1270             dyj=dc_norm(2,nres+j)
1271             dzj=dc_norm(3,nres+j)
1272 c            write (iout,*) i,j,xj,yj,zj
1273             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1274             rij=dsqrt(rrij)
1275             sss=sscale(1.0d0/rij))
1276             sssgrad=sscagrad(1.0d0/rij)
1277             if (sss.le.0.0) cycle
1278 C Calculate angle-dependent terms of energy and contributions to their
1279 C derivatives.
1280
1281             call sc_angular
1282             sigsq=1.0D0/sigsq
1283             sig=sig0ij*dsqrt(sigsq)
1284             rij_shift=1.0D0/rij-sig+sig0ij
1285 C I hate to put IF's in the loops, but here don't have another choice!!!!
1286             if (rij_shift.le.0.0D0) then
1287               evdw=1.0D20
1288               return
1289             endif
1290             sigder=-sig*sigsq
1291 c---------------------------------------------------------------
1292             rij_shift=1.0D0/rij_shift
1293             fac=rij_shift**expon
1294             e1=fac*fac*aa
1295             e2=fac*bb
1296             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1297             eps2der=evdwij*eps3rt
1298             eps3der=evdwij*eps2rt
1299             evdwij=evdwij*eps2rt*eps3rt
1300             if (bb.gt.0) then
1301               evdw=evdw+evdwij*sss
1302             else
1303               evdw_t=evdw_t+evdwij*sss
1304             endif
1305             ij=icant(itypi,itypj)
1306             aux=eps1*eps2rt**2*eps3rt**2
1307 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1308 c     &        /dabs(eps(itypi,itypj))
1309 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1310 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1311 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1312 c     &         aux*e2/eps(itypi,itypj)
1313 c            if (lprn) then
1314             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1315             epsi=bb**2/aa
1316 C#define DEBUG
1317 #ifdef DEBUG
1318             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1319      &        restyp(itypi),i,restyp(itypj),j,
1320      &        epsi,sigm,chi1,chi2,chip1,chip2,
1321      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1322      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1323      &        evdwij
1324              write (iout,*) "partial sum", evdw, evdw_t
1325 #endif
1326 C#undef DEBUG
1327 c            endif
1328             if (calc_grad) then
1329 C Calculate gradient components.
1330             e1=e1*eps1*eps2rt**2*eps3rt**2
1331             fac=-expon*(e1+evdwij)*rij_shift
1332             sigder=fac*sigder
1333             fac=rij*fac
1334             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1335 C Calculate the radial part of the gradient
1336             gg(1)=xj*fac
1337             gg(2)=yj*fac
1338             gg(3)=zj*fac
1339 C Calculate angular part of the gradient.
1340             call sc_grad
1341             endif
1342 C            write(iout,*)  "partial sum", evdw, evdw_t
1343             ENDIF    ! dyn_ss
1344           enddo      ! j
1345         enddo        ! iint
1346       enddo          ! i
1347       return
1348       end
1349 C-----------------------------------------------------------------------------
1350       subroutine egbv(evdw,evdw_t)
1351 C
1352 C This subroutine calculates the interaction energy of nonbonded side chains
1353 C assuming the Gay-Berne-Vorobjev potential of interaction.
1354 C
1355       implicit real*8 (a-h,o-z)
1356       include 'DIMENSIONS'
1357       include "DIMENSIONS.COMPAR"
1358       include 'COMMON.GEO'
1359       include 'COMMON.VAR'
1360       include 'COMMON.LOCAL'
1361       include 'COMMON.CHAIN'
1362       include 'COMMON.DERIV'
1363       include 'COMMON.NAMES'
1364       include 'COMMON.INTERACT'
1365       include 'COMMON.IOUNITS'
1366       include 'COMMON.CALC'
1367       common /srutu/ icall
1368       logical lprn
1369       integer icant
1370       external icant
1371 c      do i=1,210
1372 c        do j=1,2
1373 c          eneps_temp(j,i)=0.0d0
1374 c        enddo
1375 c      enddo
1376       evdw=0.0D0
1377       evdw_t=0.0d0
1378 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1379       evdw=0.0D0
1380       lprn=.false.
1381 c      if (icall.gt.0) lprn=.true.
1382       ind=0
1383       do i=iatsc_s,iatsc_e
1384         itypi=iabs(itype(i))
1385         if (itypi.eq.ntyp1) cycle
1386         itypi1=iabs(itype(i+1))
1387         xi=c(1,nres+i)
1388         yi=c(2,nres+i)
1389         zi=c(3,nres+i)
1390         dxi=dc_norm(1,nres+i)
1391         dyi=dc_norm(2,nres+i)
1392         dzi=dc_norm(3,nres+i)
1393         dsci_inv=vbld_inv(i+nres)
1394 C
1395 C Calculate SC interaction energy.
1396 C
1397         do iint=1,nint_gr(i)
1398           do j=istart(i,iint),iend(i,iint)
1399             ind=ind+1
1400             itypj=iabs(itype(j))
1401             if (itypj.eq.ntyp1) cycle
1402             dscj_inv=vbld_inv(j+nres)
1403             sig0ij=sigma(itypi,itypj)
1404             r0ij=r0(itypi,itypj)
1405             chi1=chi(itypi,itypj)
1406             chi2=chi(itypj,itypi)
1407             chi12=chi1*chi2
1408             chip1=chip(itypi)
1409             chip2=chip(itypj)
1410             chip12=chip1*chip2
1411             alf1=alp(itypi)
1412             alf2=alp(itypj)
1413             alf12=0.5D0*(alf1+alf2)
1414 C For diagnostics only!!!
1415 c           chi1=0.0D0
1416 c           chi2=0.0D0
1417 c           chi12=0.0D0
1418 c           chip1=0.0D0
1419 c           chip2=0.0D0
1420 c           chip12=0.0D0
1421 c           alf1=0.0D0
1422 c           alf2=0.0D0
1423 c           alf12=0.0D0
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             dxj=dc_norm(1,nres+j)
1428             dyj=dc_norm(2,nres+j)
1429             dzj=dc_norm(3,nres+j)
1430             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1431             rij=dsqrt(rrij)
1432             sss=sscale(1.0d0/rij)
1433             if (sss.eq.0.0d0) cycle
1434             sssgrad=sscagrad(1.0d0/rij)
1435 C Calculate angle-dependent terms of energy and contributions to their
1436 C derivatives.
1437             call sc_angular
1438             sigsq=1.0D0/sigsq
1439             sig=sig0ij*dsqrt(sigsq)
1440             rij_shift=1.0D0/rij-sig+r0ij
1441 C I hate to put IF's in the loops, but here don't have another choice!!!!
1442             if (rij_shift.le.0.0D0) then
1443               evdw=1.0D20
1444               return
1445             endif
1446             sigder=-sig*sigsq
1447 c---------------------------------------------------------------
1448             rij_shift=1.0D0/rij_shift
1449             fac=rij_shift**expon
1450             e1=fac*fac*aa
1451             e2=fac*bb
1452             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1453             eps2der=evdwij*eps3rt
1454             eps3der=evdwij*eps2rt
1455             fac_augm=rrij**expon
1456             e_augm=augm(itypi,itypj)*fac_augm
1457             evdwij=evdwij*eps2rt*eps3rt
1458             if (bb.gt.0.0d0) then
1459               evdw=evdw+(evdwij+e_augm)*sss
1460             else
1461               evdw_t=evdw_t+(evdwij+e_augm)*sss
1462             endif
1463             ij=icant(itypi,itypj)
1464             aux=eps1*eps2rt**2*eps3rt**2
1465 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1466 c     &        /dabs(eps(itypi,itypj))
1467 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1468 c            eneps_temp(ij)=eneps_temp(ij)
1469 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1470 c            if (lprn) then
1471 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1472 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1473 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1474 c     &        restyp(itypi),i,restyp(itypj),j,
1475 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1476 c     &        chi1,chi2,chip1,chip2,
1477 c     &        eps1,eps2rt**2,eps3rt**2,
1478 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1479 c     &        evdwij+e_augm
1480 c            endif
1481             if (calc_grad) then
1482 C Calculate gradient components.
1483             e1=e1*eps1*eps2rt**2*eps3rt**2
1484             fac=-expon*(e1+evdwij)*rij_shift
1485             sigder=fac*sigder
1486             fac=rij*fac-2*expon*rrij*e_augm
1487             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1488 C Calculate the radial part of the gradient
1489             gg(1)=xj*fac
1490             gg(2)=yj*fac
1491             gg(3)=zj*fac
1492 C Calculate angular part of the gradient.
1493             call sc_grad
1494             endif
1495           enddo      ! j
1496         enddo        ! iint
1497       enddo          ! i
1498       return
1499       end
1500 C-----------------------------------------------------------------------------
1501       subroutine sc_angular
1502 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1503 C om12. Called by ebp, egb, and egbv.
1504       implicit none
1505       include 'COMMON.CALC'
1506       erij(1)=xj*rij
1507       erij(2)=yj*rij
1508       erij(3)=zj*rij
1509       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1510       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1511       om12=dxi*dxj+dyi*dyj+dzi*dzj
1512       chiom12=chi12*om12
1513 C Calculate eps1(om12) and its derivative in om12
1514       faceps1=1.0D0-om12*chiom12
1515       faceps1_inv=1.0D0/faceps1
1516       eps1=dsqrt(faceps1_inv)
1517 C Following variable is eps1*deps1/dom12
1518       eps1_om12=faceps1_inv*chiom12
1519 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1520 C and om12.
1521       om1om2=om1*om2
1522       chiom1=chi1*om1
1523       chiom2=chi2*om2
1524       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1525       sigsq=1.0D0-facsig*faceps1_inv
1526       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1527       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1528       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1529 C Calculate eps2 and its derivatives in om1, om2, and om12.
1530       chipom1=chip1*om1
1531       chipom2=chip2*om2
1532       chipom12=chip12*om12
1533       facp=1.0D0-om12*chipom12
1534       facp_inv=1.0D0/facp
1535       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1536 C Following variable is the square root of eps2
1537       eps2rt=1.0D0-facp1*facp_inv
1538 C Following three variables are the derivatives of the square root of eps
1539 C in om1, om2, and om12.
1540       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1541       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1542       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1543 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1544       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1545 C Calculate whole angle-dependent part of epsilon and contributions
1546 C to its derivatives
1547       return
1548       end
1549 C----------------------------------------------------------------------------
1550       subroutine sc_grad
1551       implicit real*8 (a-h,o-z)
1552       include 'DIMENSIONS'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.CALC'
1556       double precision dcosom1(3),dcosom2(3)
1557       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1558       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1559       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1560      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1561       do k=1,3
1562         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1563         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1564       enddo
1565       do k=1,3
1566         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1567       enddo
1568       do k=1,3
1569         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1570      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1571      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1572         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1573      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1574      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1575       enddo
1576 C
1577 C Calculate the components of the gradient in DC and X
1578 C
1579       do k=i,j-1
1580         do l=1,3
1581           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1582         enddo
1583       enddo
1584       return
1585       end
1586 c------------------------------------------------------------------------------
1587       subroutine vec_and_deriv
1588       implicit real*8 (a-h,o-z)
1589       include 'DIMENSIONS'
1590       include 'COMMON.IOUNITS'
1591       include 'COMMON.GEO'
1592       include 'COMMON.VAR'
1593       include 'COMMON.LOCAL'
1594       include 'COMMON.CHAIN'
1595       include 'COMMON.VECTORS'
1596       include 'COMMON.DERIV'
1597       include 'COMMON.INTERACT'
1598       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1599 C Compute the local reference systems. For reference system (i), the
1600 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1601 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1602       do i=1,nres-1
1603 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1604           if (i.eq.nres-1) then
1605 C Case of the last full residue
1606 C Compute the Z-axis
1607             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1608             costh=dcos(pi-theta(nres))
1609             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1610 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1611 c     &         " uz",uz(:,i)
1612             do k=1,3
1613               uz(k,i)=fac*uz(k,i)
1614             enddo
1615             if (calc_grad) then
1616 C Compute the derivatives of uz
1617             uzder(1,1,1)= 0.0d0
1618             uzder(2,1,1)=-dc_norm(3,i-1)
1619             uzder(3,1,1)= dc_norm(2,i-1)
1620             uzder(1,2,1)= dc_norm(3,i-1)
1621             uzder(2,2,1)= 0.0d0
1622             uzder(3,2,1)=-dc_norm(1,i-1)
1623             uzder(1,3,1)=-dc_norm(2,i-1)
1624             uzder(2,3,1)= dc_norm(1,i-1)
1625             uzder(3,3,1)= 0.0d0
1626             uzder(1,1,2)= 0.0d0
1627             uzder(2,1,2)= dc_norm(3,i)
1628             uzder(3,1,2)=-dc_norm(2,i)
1629             uzder(1,2,2)=-dc_norm(3,i)
1630             uzder(2,2,2)= 0.0d0
1631             uzder(3,2,2)= dc_norm(1,i)
1632             uzder(1,3,2)= dc_norm(2,i)
1633             uzder(2,3,2)=-dc_norm(1,i)
1634             uzder(3,3,2)= 0.0d0
1635             endif ! calc_grad
1636 C Compute the Y-axis
1637             facy=fac
1638             do k=1,3
1639               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1640             enddo
1641             if (calc_grad) then
1642 C Compute the derivatives of uy
1643             do j=1,3
1644               do k=1,3
1645                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1646      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1647                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1648               enddo
1649               uyder(j,j,1)=uyder(j,j,1)-costh
1650               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1651             enddo
1652             do j=1,2
1653               do k=1,3
1654                 do l=1,3
1655                   uygrad(l,k,j,i)=uyder(l,k,j)
1656                   uzgrad(l,k,j,i)=uzder(l,k,j)
1657                 enddo
1658               enddo
1659             enddo
1660             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1661             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1662             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1663             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1664             endif
1665           else
1666 C Other residues
1667 C Compute the Z-axis
1668             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1669             costh=dcos(pi-theta(i+2))
1670             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1671             do k=1,3
1672               uz(k,i)=fac*uz(k,i)
1673             enddo
1674             if (calc_grad) then
1675 C Compute the derivatives of uz
1676             uzder(1,1,1)= 0.0d0
1677             uzder(2,1,1)=-dc_norm(3,i+1)
1678             uzder(3,1,1)= dc_norm(2,i+1)
1679             uzder(1,2,1)= dc_norm(3,i+1)
1680             uzder(2,2,1)= 0.0d0
1681             uzder(3,2,1)=-dc_norm(1,i+1)
1682             uzder(1,3,1)=-dc_norm(2,i+1)
1683             uzder(2,3,1)= dc_norm(1,i+1)
1684             uzder(3,3,1)= 0.0d0
1685             uzder(1,1,2)= 0.0d0
1686             uzder(2,1,2)= dc_norm(3,i)
1687             uzder(3,1,2)=-dc_norm(2,i)
1688             uzder(1,2,2)=-dc_norm(3,i)
1689             uzder(2,2,2)= 0.0d0
1690             uzder(3,2,2)= dc_norm(1,i)
1691             uzder(1,3,2)= dc_norm(2,i)
1692             uzder(2,3,2)=-dc_norm(1,i)
1693             uzder(3,3,2)= 0.0d0
1694             endif
1695 C Compute the Y-axis
1696             facy=fac
1697             do k=1,3
1698               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1699             enddo
1700             if (calc_grad) then
1701 C Compute the derivatives of uy
1702             do j=1,3
1703               do k=1,3
1704                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1705      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1706                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1707               enddo
1708               uyder(j,j,1)=uyder(j,j,1)-costh
1709               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1710             enddo
1711             do j=1,2
1712               do k=1,3
1713                 do l=1,3
1714                   uygrad(l,k,j,i)=uyder(l,k,j)
1715                   uzgrad(l,k,j,i)=uzder(l,k,j)
1716                 enddo
1717               enddo
1718             enddo
1719             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1720             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1721             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1722             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1723           endif
1724           endif
1725       enddo
1726       if (calc_grad) then
1727       do i=1,nres-1
1728         vbld_inv_temp(1)=vbld_inv(i+1)
1729         if (i.lt.nres-1) then
1730           vbld_inv_temp(2)=vbld_inv(i+2)
1731         else
1732           vbld_inv_temp(2)=vbld_inv(i)
1733         endif
1734         do j=1,2
1735           do k=1,3
1736             do l=1,3
1737               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1738               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1739             enddo
1740           enddo
1741         enddo
1742       enddo
1743       endif
1744       return
1745       end
1746 C--------------------------------------------------------------------------
1747       subroutine set_matrices
1748       implicit real*8 (a-h,o-z)
1749       include 'DIMENSIONS'
1750 #ifdef MPI
1751       include "mpif.h"
1752       integer IERR
1753       integer status(MPI_STATUS_SIZE)
1754 #endif
1755       include 'COMMON.IOUNITS'
1756       include 'COMMON.GEO'
1757       include 'COMMON.VAR'
1758       include 'COMMON.LOCAL'
1759       include 'COMMON.CHAIN'
1760       include 'COMMON.DERIV'
1761       include 'COMMON.INTERACT'
1762       include 'COMMON.CONTACTS'
1763       include 'COMMON.TORSION'
1764       include 'COMMON.VECTORS'
1765       include 'COMMON.FFIELD'
1766       include 'COMMON.CORRMAT'
1767       double precision auxvec(2),auxmat(2,2)
1768 C
1769 C Compute the virtual-bond-torsional-angle dependent quantities needed
1770 C to calculate the el-loc multibody terms of various order.
1771 C
1772 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1773       do i=3,nres+1
1774         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1775           iti = itype2loc(itype(i-2))
1776         else
1777           iti=nloctyp
1778         endif
1779 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1780         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1781           iti1 = itype2loc(itype(i-1))
1782         else
1783           iti1=nloctyp
1784         endif
1785 #ifdef NEWCORR
1786         cost1=dcos(theta(i-1))
1787         sint1=dsin(theta(i-1))
1788         sint1sq=sint1*sint1
1789         sint1cub=sint1sq*sint1
1790         sint1cost1=2*sint1*cost1
1791 #ifdef DEBUG
1792         write (iout,*) "bnew1",i,iti
1793         write (iout,*) (bnew1(k,1,iti),k=1,3)
1794         write (iout,*) (bnew1(k,2,iti),k=1,3)
1795         write (iout,*) "bnew2",i,iti
1796         write (iout,*) (bnew2(k,1,iti),k=1,3)
1797         write (iout,*) (bnew2(k,2,iti),k=1,3)
1798 #endif
1799         do k=1,2
1800           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1801           b1(k,i-2)=sint1*b1k
1802           gtb1(k,i-2)=cost1*b1k-sint1sq*
1803      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1804           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1805           b2(k,i-2)=sint1*b2k
1806           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1807      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1808         enddo
1809         do k=1,2
1810           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1811           cc(1,k,i-2)=sint1sq*aux
1812           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1813      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1814           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1815           dd(1,k,i-2)=sint1sq*aux
1816           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1817      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1818         enddo
1819         cc(2,1,i-2)=cc(1,2,i-2)
1820         cc(2,2,i-2)=-cc(1,1,i-2)
1821         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1822         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1823         dd(2,1,i-2)=dd(1,2,i-2)
1824         dd(2,2,i-2)=-dd(1,1,i-2)
1825         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1826         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1827         do k=1,2
1828           do l=1,2
1829             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1830             EE(l,k,i-2)=sint1sq*aux
1831             if (calc_grad)
1832      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1833           enddo
1834         enddo
1835         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1836         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1837         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1838         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1839         if (calc_grad) then
1840         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1841         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1842         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1843         endif
1844 c        b1tilde(1,i-2)=b1(1,i-2)
1845 c        b1tilde(2,i-2)=-b1(2,i-2)
1846 c        b2tilde(1,i-2)=b2(1,i-2)
1847 c        b2tilde(2,i-2)=-b2(2,i-2)
1848 #ifdef DEBUG
1849         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1850         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1851         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1852         write (iout,*) 'theta=', theta(i-1)
1853 #endif
1854 #else
1855 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1856 c          iti = itype2loc(itype(i-2))
1857 c        else
1858 c          iti=nloctyp
1859 c        endif
1860 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1861 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1862 c          iti1 = itype2loc(itype(i-1))
1863 c        else
1864 c          iti1=nloctyp
1865 c        endif
1866         b1(1,i-2)=b(3,iti)
1867         b1(2,i-2)=b(5,iti)
1868         b2(1,i-2)=b(2,iti)
1869         b2(2,i-2)=b(4,iti)
1870         do k=1,2
1871           do l=1,2
1872            CC(k,l,i-2)=ccold(k,l,iti)
1873            DD(k,l,i-2)=ddold(k,l,iti)
1874            EE(k,l,i-2)=eeold(k,l,iti)
1875           enddo
1876         enddo
1877 #endif
1878         b1tilde(1,i-2)= b1(1,i-2)
1879         b1tilde(2,i-2)=-b1(2,i-2)
1880         b2tilde(1,i-2)= b2(1,i-2)
1881         b2tilde(2,i-2)=-b2(2,i-2)
1882 c
1883         Ctilde(1,1,i-2)= CC(1,1,i-2)
1884         Ctilde(1,2,i-2)= CC(1,2,i-2)
1885         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1886         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1887 c
1888         Dtilde(1,1,i-2)= DD(1,1,i-2)
1889         Dtilde(1,2,i-2)= DD(1,2,i-2)
1890         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1891         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1892 c        write(iout,*) "i",i," iti",iti
1893 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1894 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1895       enddo
1896       do i=3,nres+1
1897         if (i .lt. nres+1) then
1898           sin1=dsin(phi(i))
1899           cos1=dcos(phi(i))
1900           sintab(i-2)=sin1
1901           costab(i-2)=cos1
1902           obrot(1,i-2)=cos1
1903           obrot(2,i-2)=sin1
1904           sin2=dsin(2*phi(i))
1905           cos2=dcos(2*phi(i))
1906           sintab2(i-2)=sin2
1907           costab2(i-2)=cos2
1908           obrot2(1,i-2)=cos2
1909           obrot2(2,i-2)=sin2
1910           Ug(1,1,i-2)=-cos1
1911           Ug(1,2,i-2)=-sin1
1912           Ug(2,1,i-2)=-sin1
1913           Ug(2,2,i-2)= cos1
1914           Ug2(1,1,i-2)=-cos2
1915           Ug2(1,2,i-2)=-sin2
1916           Ug2(2,1,i-2)=-sin2
1917           Ug2(2,2,i-2)= cos2
1918         else
1919           costab(i-2)=1.0d0
1920           sintab(i-2)=0.0d0
1921           obrot(1,i-2)=1.0d0
1922           obrot(2,i-2)=0.0d0
1923           obrot2(1,i-2)=0.0d0
1924           obrot2(2,i-2)=0.0d0
1925           Ug(1,1,i-2)=1.0d0
1926           Ug(1,2,i-2)=0.0d0
1927           Ug(2,1,i-2)=0.0d0
1928           Ug(2,2,i-2)=1.0d0
1929           Ug2(1,1,i-2)=0.0d0
1930           Ug2(1,2,i-2)=0.0d0
1931           Ug2(2,1,i-2)=0.0d0
1932           Ug2(2,2,i-2)=0.0d0
1933         endif
1934         if (i .gt. 3 .and. i .lt. nres+1) then
1935           obrot_der(1,i-2)=-sin1
1936           obrot_der(2,i-2)= cos1
1937           Ugder(1,1,i-2)= sin1
1938           Ugder(1,2,i-2)=-cos1
1939           Ugder(2,1,i-2)=-cos1
1940           Ugder(2,2,i-2)=-sin1
1941           dwacos2=cos2+cos2
1942           dwasin2=sin2+sin2
1943           obrot2_der(1,i-2)=-dwasin2
1944           obrot2_der(2,i-2)= dwacos2
1945           Ug2der(1,1,i-2)= dwasin2
1946           Ug2der(1,2,i-2)=-dwacos2
1947           Ug2der(2,1,i-2)=-dwacos2
1948           Ug2der(2,2,i-2)=-dwasin2
1949         else
1950           obrot_der(1,i-2)=0.0d0
1951           obrot_der(2,i-2)=0.0d0
1952           Ugder(1,1,i-2)=0.0d0
1953           Ugder(1,2,i-2)=0.0d0
1954           Ugder(2,1,i-2)=0.0d0
1955           Ugder(2,2,i-2)=0.0d0
1956           obrot2_der(1,i-2)=0.0d0
1957           obrot2_der(2,i-2)=0.0d0
1958           Ug2der(1,1,i-2)=0.0d0
1959           Ug2der(1,2,i-2)=0.0d0
1960           Ug2der(2,1,i-2)=0.0d0
1961           Ug2der(2,2,i-2)=0.0d0
1962         endif
1963 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1964         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1965           iti = itype2loc(itype(i-2))
1966         else
1967           iti=nloctyp
1968         endif
1969 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1970         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1971           iti1 = itype2loc(itype(i-1))
1972         else
1973           iti1=nloctyp
1974         endif
1975 cd        write (iout,*) '*******i',i,' iti1',iti
1976 cd        write (iout,*) 'b1',b1(:,iti)
1977 cd        write (iout,*) 'b2',b2(:,iti)
1978 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1979 c        if (i .gt. iatel_s+2) then
1980         if (i .gt. nnt+2) then
1981           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1982 #ifdef NEWCORR
1983           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1984 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1985 #endif
1986 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1987 c     &    EE(1,2,iti),EE(2,2,i)
1988           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1989           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1990 c          write(iout,*) "Macierz EUG",
1991 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1992 c     &    eug(2,2,i-2)
1993 #ifdef FOURBODY
1994           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1995      &    then
1996           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1997           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1998           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1999           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2000           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2001           endif
2002 #endif
2003         else
2004           do k=1,2
2005             Ub2(k,i-2)=0.0d0
2006             Ctobr(k,i-2)=0.0d0
2007             Dtobr2(k,i-2)=0.0d0
2008             do l=1,2
2009               EUg(l,k,i-2)=0.0d0
2010               CUg(l,k,i-2)=0.0d0
2011               DUg(l,k,i-2)=0.0d0
2012               DtUg2(l,k,i-2)=0.0d0
2013             enddo
2014           enddo
2015         endif
2016         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2017         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2018         do k=1,2
2019           muder(k,i-2)=Ub2der(k,i-2)
2020         enddo
2021 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2022         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2023           if (itype(i-1).le.ntyp) then
2024             iti1 = itype2loc(itype(i-1))
2025           else
2026             iti1=nloctyp
2027           endif
2028         else
2029           iti1=nloctyp
2030         endif
2031         do k=1,2
2032           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2033         enddo
2034 #ifdef MUOUT
2035         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2036      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2037      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2038      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2039      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2040      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2041 #endif
2042 cd        write (iout,*) 'mu1',mu1(:,i-2)
2043 cd        write (iout,*) 'mu2',mu2(:,i-2)
2044 #ifdef FOURBODY
2045         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2046      &  then
2047         if (calc_grad) then
2048         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2049         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2050         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2051         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2052         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2053         endif
2054 C Vectors and matrices dependent on a single virtual-bond dihedral.
2055         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2056         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2057         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2058         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2059         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2060         if (calc_grad) then
2061         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2062         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2063         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2064         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2065         endif
2066         endif
2067 #endif
2068       enddo
2069 #ifdef FOURBODY
2070 C Matrices dependent on two consecutive virtual-bond dihedrals.
2071 C The order of matrices is from left to right.
2072       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2073      &then
2074       do i=2,nres-1
2075         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2076         if (calc_grad) then
2077         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2078         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2079         endif
2080         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2081         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2082         if (calc_grad) then
2083         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2084         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2085         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2086         endif
2087 #endif
2088       enddo
2089       endif
2090       return
2091       end
2092 C--------------------------------------------------------------------------
2093       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2094 C
2095 C This subroutine calculates the average interaction energy and its gradient
2096 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2097 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2098 C The potential depends both on the distance of peptide-group centers and on
2099 C the orientation of the CA-CA virtual bonds.
2100 C
2101       implicit real*8 (a-h,o-z)
2102 #ifdef MPI
2103       include 'mpif.h'
2104 #endif
2105       include 'DIMENSIONS'
2106       include 'COMMON.CONTROL'
2107       include 'COMMON.IOUNITS'
2108       include 'COMMON.GEO'
2109       include 'COMMON.VAR'
2110       include 'COMMON.LOCAL'
2111       include 'COMMON.CHAIN'
2112       include 'COMMON.DERIV'
2113       include 'COMMON.INTERACT'
2114 #ifdef FOURBODY
2115       include 'COMMON.CONTACTS'
2116       include 'COMMON.CONTMAP'
2117 #endif
2118       include 'COMMON.CORRMAT'
2119       include 'COMMON.TORSION'
2120       include 'COMMON.VECTORS'
2121       include 'COMMON.FFIELD'
2122       include 'COMMON.TIME1'
2123       include 'COMMON.SPLITELE'
2124       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2125      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2126       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2127      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2128       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2129      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2130      &    num_conti,j1,j2
2131 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2132 #ifdef MOMENT
2133       double precision scal_el /1.0d0/
2134 #else
2135       double precision scal_el /0.5d0/
2136 #endif
2137 C 12/13/98
2138 C 13-go grudnia roku pamietnego...
2139       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2140      &                   0.0d0,1.0d0,0.0d0,
2141      &                   0.0d0,0.0d0,1.0d0/
2142 cd      write(iout,*) 'In EELEC'
2143 cd      do i=1,nloctyp
2144 cd        write(iout,*) 'Type',i
2145 cd        write(iout,*) 'B1',B1(:,i)
2146 cd        write(iout,*) 'B2',B2(:,i)
2147 cd        write(iout,*) 'CC',CC(:,:,i)
2148 cd        write(iout,*) 'DD',DD(:,:,i)
2149 cd        write(iout,*) 'EE',EE(:,:,i)
2150 cd      enddo
2151 cd      call check_vecgrad
2152 cd      stop
2153       if (icheckgrad.eq.1) then
2154         do i=1,nres-1
2155           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2156           do k=1,3
2157             dc_norm(k,i)=dc(k,i)*fac
2158           enddo
2159 c          write (iout,*) 'i',i,' fac',fac
2160         enddo
2161       endif
2162       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2163      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2164      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2165 c        call vec_and_deriv
2166 #ifdef TIMING
2167         time01=MPI_Wtime()
2168 #endif
2169         call set_matrices
2170 #ifdef TIMING
2171         time_mat=time_mat+MPI_Wtime()-time01
2172 #endif
2173       endif
2174 cd      do i=1,nres-1
2175 cd        write (iout,*) 'i=',i
2176 cd        do k=1,3
2177 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2178 cd        enddo
2179 cd        do k=1,3
2180 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2181 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2182 cd        enddo
2183 cd      enddo
2184       t_eelecij=0.0d0
2185       ees=0.0D0
2186       evdw1=0.0D0
2187       eel_loc=0.0d0
2188       eello_turn3=0.0d0
2189       eello_turn4=0.0d0
2190       ind=0
2191 #ifdef FOURBODY
2192       do i=1,nres
2193         num_cont_hb(i)=0
2194       enddo
2195 #endif
2196 cd      print '(a)','Enter EELEC'
2197 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2198 c      call flush(iout)
2199       do i=1,nres
2200         gel_loc_loc(i)=0.0d0
2201         gcorr_loc(i)=0.0d0
2202       enddo
2203 c
2204 c
2205 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2206 C
2207 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2208 C
2209 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2210       do i=iturn3_start,iturn3_end
2211 c        if (i.le.1) cycle
2212 C        write(iout,*) "tu jest i",i
2213         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2214 C changes suggested by Ana to avoid out of bounds
2215 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2216 c     & .or.((i+4).gt.nres)
2217 c     & .or.((i-1).le.0)
2218 C end of changes by Ana
2219 C dobra zmiana wycofana
2220      &  .or. itype(i+2).eq.ntyp1
2221      &  .or. itype(i+3).eq.ntyp1) cycle
2222 C Adam: Instructions below will switch off existing interactions
2223 c        if(i.gt.1)then
2224 c          if(itype(i-1).eq.ntyp1)cycle
2225 c        end if
2226 c        if(i.LT.nres-3)then
2227 c          if (itype(i+4).eq.ntyp1) cycle
2228 c        end if
2229         dxi=dc(1,i)
2230         dyi=dc(2,i)
2231         dzi=dc(3,i)
2232         dx_normi=dc_norm(1,i)
2233         dy_normi=dc_norm(2,i)
2234         dz_normi=dc_norm(3,i)
2235         xmedi=c(1,i)+0.5d0*dxi
2236         ymedi=c(2,i)+0.5d0*dyi
2237         zmedi=c(3,i)+0.5d0*dzi
2238           xmedi=mod(xmedi,boxxsize)
2239           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2240           ymedi=mod(ymedi,boxysize)
2241           if (ymedi.lt.0) ymedi=ymedi+boxysize
2242           zmedi=mod(zmedi,boxzsize)
2243           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2244         num_conti=0
2245         call eelecij(i,i+2,ees,evdw1,eel_loc)
2246         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2247 #ifdef FOURBODY
2248         num_cont_hb(i)=num_conti
2249 #endif
2250       enddo
2251       do i=iturn4_start,iturn4_end
2252         if (i.lt.1) cycle
2253         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2254 C changes suggested by Ana to avoid out of bounds
2255 c     & .or.((i+5).gt.nres)
2256 c     & .or.((i-1).le.0)
2257 C end of changes suggested by Ana
2258      &    .or. itype(i+3).eq.ntyp1
2259      &    .or. itype(i+4).eq.ntyp1
2260 c     &    .or. itype(i+5).eq.ntyp1
2261 c     &    .or. itype(i).eq.ntyp1
2262 c     &    .or. itype(i-1).eq.ntyp1
2263      &                             ) cycle
2264         dxi=dc(1,i)
2265         dyi=dc(2,i)
2266         dzi=dc(3,i)
2267         dx_normi=dc_norm(1,i)
2268         dy_normi=dc_norm(2,i)
2269         dz_normi=dc_norm(3,i)
2270         xmedi=c(1,i)+0.5d0*dxi
2271         ymedi=c(2,i)+0.5d0*dyi
2272         zmedi=c(3,i)+0.5d0*dzi
2273 C Return atom into box, boxxsize is size of box in x dimension
2274 c  194   continue
2275 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2276 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2277 C Condition for being inside the proper box
2278 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2279 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2280 c        go to 194
2281 c        endif
2282 c  195   continue
2283 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2284 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2285 C Condition for being inside the proper box
2286 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2287 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2288 c        go to 195
2289 c        endif
2290 c  196   continue
2291 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2292 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2293 C Condition for being inside the proper box
2294 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2295 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2296 c        go to 196
2297 c        endif
2298           xmedi=mod(xmedi,boxxsize)
2299           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2300           ymedi=mod(ymedi,boxysize)
2301           if (ymedi.lt.0) ymedi=ymedi+boxysize
2302           zmedi=mod(zmedi,boxzsize)
2303           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2304
2305 #ifdef FOURBODY
2306         num_conti=num_cont_hb(i)
2307 #endif
2308 c        write(iout,*) "JESTEM W PETLI"
2309         call eelecij(i,i+3,ees,evdw1,eel_loc)
2310         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2311      &   call eturn4(i,eello_turn4)
2312 #ifdef FOURBODY
2313         num_cont_hb(i)=num_conti
2314 #endif
2315       enddo   ! i
2316 C Loop over all neighbouring boxes
2317 C      do xshift=-1,1
2318 C      do yshift=-1,1
2319 C      do zshift=-1,1
2320 c
2321 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2322 c
2323 CTU KURWA
2324       do i=iatel_s,iatel_e
2325 C        do i=75,75
2326 c        if (i.le.1) cycle
2327         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2328 C changes suggested by Ana to avoid out of bounds
2329 c     & .or.((i+2).gt.nres)
2330 c     & .or.((i-1).le.0)
2331 C end of changes by Ana
2332 c     &  .or. itype(i+2).eq.ntyp1
2333 c     &  .or. itype(i-1).eq.ntyp1
2334      &                ) cycle
2335         dxi=dc(1,i)
2336         dyi=dc(2,i)
2337         dzi=dc(3,i)
2338         dx_normi=dc_norm(1,i)
2339         dy_normi=dc_norm(2,i)
2340         dz_normi=dc_norm(3,i)
2341         xmedi=c(1,i)+0.5d0*dxi
2342         ymedi=c(2,i)+0.5d0*dyi
2343         zmedi=c(3,i)+0.5d0*dzi
2344           xmedi=mod(xmedi,boxxsize)
2345           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2346           ymedi=mod(ymedi,boxysize)
2347           if (ymedi.lt.0) ymedi=ymedi+boxysize
2348           zmedi=mod(zmedi,boxzsize)
2349           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2350 C          xmedi=xmedi+xshift*boxxsize
2351 C          ymedi=ymedi+yshift*boxysize
2352 C          zmedi=zmedi+zshift*boxzsize
2353
2354 C Return tom into box, boxxsize is size of box in x dimension
2355 c  164   continue
2356 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2357 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2358 C Condition for being inside the proper box
2359 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2360 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2361 c        go to 164
2362 c        endif
2363 c  165   continue
2364 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2365 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2366 C Condition for being inside the proper box
2367 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2368 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2369 c        go to 165
2370 c        endif
2371 c  166   continue
2372 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2373 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2374 cC Condition for being inside the proper box
2375 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2376 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2377 c        go to 166
2378 c        endif
2379
2380 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2381 #ifdef FOURBODY
2382         num_conti=num_cont_hb(i)
2383 #endif
2384 C I TU KURWA
2385         do j=ielstart(i),ielend(i)
2386 C          do j=16,17
2387 C          write (iout,*) i,j
2388 C         if (j.le.1) cycle
2389           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2390 C changes suggested by Ana to avoid out of bounds
2391 c     & .or.((j+2).gt.nres)
2392 c     & .or.((j-1).le.0)
2393 C end of changes by Ana
2394 c     & .or.itype(j+2).eq.ntyp1
2395 c     & .or.itype(j-1).eq.ntyp1
2396      &) cycle
2397           call eelecij(i,j,ees,evdw1,eel_loc)
2398         enddo ! j
2399 #ifdef FOURBODY
2400         num_cont_hb(i)=num_conti
2401 #endif
2402       enddo   ! i
2403 C     enddo   ! zshift
2404 C      enddo   ! yshift
2405 C      enddo   ! xshift
2406
2407 c      write (iout,*) "Number of loop steps in EELEC:",ind
2408 cd      do i=1,nres
2409 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2410 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2411 cd      enddo
2412 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2413 ccc      eel_loc=eel_loc+eello_turn3
2414 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2415       return
2416       end
2417 C-------------------------------------------------------------------------------
2418       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2419       implicit real*8 (a-h,o-z)
2420       include 'DIMENSIONS'
2421 #ifdef MPI
2422       include "mpif.h"
2423 #endif
2424       include 'COMMON.CONTROL'
2425       include 'COMMON.IOUNITS'
2426       include 'COMMON.GEO'
2427       include 'COMMON.VAR'
2428       include 'COMMON.LOCAL'
2429       include 'COMMON.CHAIN'
2430       include 'COMMON.DERIV'
2431       include 'COMMON.INTERACT'
2432 #ifdef FOURBODY
2433       include 'COMMON.CONTACTS'
2434       include 'COMMON.CONTMAP'
2435 #endif
2436       include 'COMMON.CORRMAT'
2437       include 'COMMON.TORSION'
2438       include 'COMMON.VECTORS'
2439       include 'COMMON.FFIELD'
2440       include 'COMMON.TIME1'
2441       include 'COMMON.SPLITELE'
2442       include 'COMMON.SHIELD'
2443       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2444      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2445       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2446      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2447      &    gmuij2(4),gmuji2(4)
2448       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2449      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2450      &    num_conti,j1,j2
2451 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2452 #ifdef MOMENT
2453       double precision scal_el /1.0d0/
2454 #else
2455       double precision scal_el /0.5d0/
2456 #endif
2457 C 12/13/98
2458 C 13-go grudnia roku pamietnego...
2459       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2460      &                   0.0d0,1.0d0,0.0d0,
2461      &                   0.0d0,0.0d0,1.0d0/
2462        integer xshift,yshift,zshift
2463 c          time00=MPI_Wtime()
2464 cd      write (iout,*) "eelecij",i,j
2465 c          ind=ind+1
2466           iteli=itel(i)
2467           itelj=itel(j)
2468           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2469           aaa=app(iteli,itelj)
2470           bbb=bpp(iteli,itelj)
2471           ael6i=ael6(iteli,itelj)
2472           ael3i=ael3(iteli,itelj)
2473           dxj=dc(1,j)
2474           dyj=dc(2,j)
2475           dzj=dc(3,j)
2476           dx_normj=dc_norm(1,j)
2477           dy_normj=dc_norm(2,j)
2478           dz_normj=dc_norm(3,j)
2479 C          xj=c(1,j)+0.5D0*dxj-xmedi
2480 C          yj=c(2,j)+0.5D0*dyj-ymedi
2481 C          zj=c(3,j)+0.5D0*dzj-zmedi
2482           xj=c(1,j)+0.5D0*dxj
2483           yj=c(2,j)+0.5D0*dyj
2484           zj=c(3,j)+0.5D0*dzj
2485           xj=mod(xj,boxxsize)
2486           if (xj.lt.0) xj=xj+boxxsize
2487           yj=mod(yj,boxysize)
2488           if (yj.lt.0) yj=yj+boxysize
2489           zj=mod(zj,boxzsize)
2490           if (zj.lt.0) zj=zj+boxzsize
2491           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2492       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2493       xj_safe=xj
2494       yj_safe=yj
2495       zj_safe=zj
2496       isubchap=0
2497       do xshift=-1,1
2498       do yshift=-1,1
2499       do zshift=-1,1
2500           xj=xj_safe+xshift*boxxsize
2501           yj=yj_safe+yshift*boxysize
2502           zj=zj_safe+zshift*boxzsize
2503           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2504           if(dist_temp.lt.dist_init) then
2505             dist_init=dist_temp
2506             xj_temp=xj
2507             yj_temp=yj
2508             zj_temp=zj
2509             isubchap=1
2510           endif
2511        enddo
2512        enddo
2513        enddo
2514        if (isubchap.eq.1) then
2515           xj=xj_temp-xmedi
2516           yj=yj_temp-ymedi
2517           zj=zj_temp-zmedi
2518        else
2519           xj=xj_safe-xmedi
2520           yj=yj_safe-ymedi
2521           zj=zj_safe-zmedi
2522        endif
2523 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2524 c  174   continue
2525 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2526 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2527 C Condition for being inside the proper box
2528 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2529 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2530 c        go to 174
2531 c        endif
2532 c  175   continue
2533 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2534 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2535 C Condition for being inside the proper box
2536 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2537 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2538 c        go to 175
2539 c        endif
2540 c  176   continue
2541 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2542 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2543 C Condition for being inside the proper box
2544 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2545 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2546 c        go to 176
2547 c        endif
2548 C        endif !endPBC condintion
2549 C        xj=xj-xmedi
2550 C        yj=yj-ymedi
2551 C        zj=zj-zmedi
2552           rij=xj*xj+yj*yj+zj*zj
2553
2554           sss=sscale(sqrt(rij))
2555           if (sss.eq.0.0d0) return
2556           sssgrad=sscagrad(sqrt(rij))
2557 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2558 c     &       " rlamb",rlamb," sss",sss
2559 c            if (sss.gt.0.0d0) then
2560           rrmij=1.0D0/rij
2561           rij=dsqrt(rij)
2562           rmij=1.0D0/rij
2563           r3ij=rrmij*rmij
2564           r6ij=r3ij*r3ij
2565           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2566           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2567           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2568           fac=cosa-3.0D0*cosb*cosg
2569           ev1=aaa*r6ij*r6ij
2570 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2571           if (j.eq.i+2) ev1=scal_el*ev1
2572           ev2=bbb*r6ij
2573           fac3=ael6i*r6ij
2574           fac4=ael3i*r3ij
2575           evdwij=(ev1+ev2)
2576           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2577           el2=fac4*fac
2578 C MARYSIA
2579 C          eesij=(el1+el2)
2580 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2581           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2582           if (shield_mode.gt.0) then
2583 C          fac_shield(i)=0.4
2584 C          fac_shield(j)=0.6
2585           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2586           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2587           eesij=(el1+el2)
2588           ees=ees+eesij
2589           else
2590           fac_shield(i)=1.0
2591           fac_shield(j)=1.0
2592           eesij=(el1+el2)
2593           ees=ees+eesij
2594           endif
2595           evdw1=evdw1+evdwij*sss
2596 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2597 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2598 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2599 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2600
2601           if (energy_dec) then
2602               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2603      &'evdw1',i,j,evdwij
2604      &,iteli,itelj,aaa,evdw1,sss
2605               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2606      &fac_shield(i),fac_shield(j)
2607           endif
2608
2609 C
2610 C Calculate contributions to the Cartesian gradient.
2611 C
2612 #ifdef SPLITELE
2613           facvdw=-6*rrmij*(ev1+evdwij)*sss
2614           facel=-3*rrmij*(el1+eesij)
2615           fac1=fac
2616           erij(1)=xj*rmij
2617           erij(2)=yj*rmij
2618           erij(3)=zj*rmij
2619
2620 *
2621 * Radial derivatives. First process both termini of the fragment (i,j)
2622 *
2623           if (calc_grad) then
2624           ggg(1)=facel*xj
2625           ggg(2)=facel*yj
2626           ggg(3)=facel*zj
2627           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2628      &  (shield_mode.gt.0)) then
2629 C          print *,i,j
2630           do ilist=1,ishield_list(i)
2631            iresshield=shield_list(ilist,i)
2632            do k=1,3
2633            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2634      &      *2.0
2635            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2636      &              rlocshield
2637      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2638             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2639 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2640 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2641 C             if (iresshield.gt.i) then
2642 C               do ishi=i+1,iresshield-1
2643 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2644 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2645 C
2646 C              enddo
2647 C             else
2648 C               do ishi=iresshield,i
2649 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2650 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2651 C
2652 C               enddo
2653 C              endif
2654            enddo
2655           enddo
2656           do ilist=1,ishield_list(j)
2657            iresshield=shield_list(ilist,j)
2658            do k=1,3
2659            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2660      &     *2.0
2661            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2662      &              rlocshield
2663      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2664            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2665
2666 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2667 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2668 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2669 C             if (iresshield.gt.j) then
2670 C               do ishi=j+1,iresshield-1
2671 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2672 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2673 C
2674 C               enddo
2675 C            else
2676 C               do ishi=iresshield,j
2677 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2678 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2679 C               enddo
2680 C              endif
2681            enddo
2682           enddo
2683
2684           do k=1,3
2685             gshieldc(k,i)=gshieldc(k,i)+
2686      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2687             gshieldc(k,j)=gshieldc(k,j)+
2688      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2689             gshieldc(k,i-1)=gshieldc(k,i-1)+
2690      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2691             gshieldc(k,j-1)=gshieldc(k,j-1)+
2692      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2693
2694            enddo
2695            endif
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 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2703           do k=1,3
2704             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2705 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2706             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2707 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2708 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2709 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2710 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2711 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2712           enddo
2713 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2714
2715 *
2716 * Loop over residues i+1 thru j-1.
2717 *
2718 cgrad          do k=i+1,j-1
2719 cgrad            do l=1,3
2720 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2721 cgrad            enddo
2722 cgrad          enddo
2723           if (sss.gt.0.0) then
2724           facvdw=facvdw+sssgrad*rmij*evdwij
2725           ggg(1)=facvdw*xj
2726           ggg(2)=facvdw*yj
2727           ggg(3)=facvdw*zj
2728           else
2729           ggg(1)=0.0
2730           ggg(2)=0.0
2731           ggg(3)=0.0
2732           endif
2733 c          do k=1,3
2734 c            ghalf=0.5D0*ggg(k)
2735 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2736 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2737 c          enddo
2738 c 9/28/08 AL Gradient compotents will be summed only at the end
2739           do k=1,3
2740             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2741             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2742           enddo
2743 *
2744 * Loop over residues i+1 thru j-1.
2745 *
2746 cgrad          do k=i+1,j-1
2747 cgrad            do l=1,3
2748 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2749 cgrad            enddo
2750 cgrad          enddo
2751           endif ! calc_grad
2752 #else
2753 C MARYSIA
2754           facvdw=(ev1+evdwij)
2755           facel=(el1+eesij)
2756           fac1=fac
2757           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2758      &       +(evdwij+eesij)*sssgrad*rrmij
2759           erij(1)=xj*rmij
2760           erij(2)=yj*rmij
2761           erij(3)=zj*rmij
2762 *
2763 * Radial derivatives. First process both termini of the fragment (i,j)
2764 *
2765           if (calc_grad) then
2766           ggg(1)=fac*xj
2767 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2768           ggg(2)=fac*yj
2769 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2770           ggg(3)=fac*zj
2771 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2772 c          do k=1,3
2773 c            ghalf=0.5D0*ggg(k)
2774 c            gelc(k,i)=gelc(k,i)+ghalf
2775 c            gelc(k,j)=gelc(k,j)+ghalf
2776 c          enddo
2777 c 9/28/08 AL Gradient compotents will be summed only at the end
2778           do k=1,3
2779             gelc_long(k,j)=gelc(k,j)+ggg(k)
2780             gelc_long(k,i)=gelc(k,i)-ggg(k)
2781           enddo
2782 *
2783 * Loop over residues i+1 thru j-1.
2784 *
2785 cgrad          do k=i+1,j-1
2786 cgrad            do l=1,3
2787 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2788 cgrad            enddo
2789 cgrad          enddo
2790 c 9/28/08 AL Gradient compotents will be summed only at the end
2791           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2792           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2793           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2794           do k=1,3
2795             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2796             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2797           enddo
2798           endif ! calc_grad
2799 #endif
2800 *
2801 * Angular part
2802 *
2803           if (calc_grad) then
2804           ecosa=2.0D0*fac3*fac1+fac4
2805           fac4=-3.0D0*fac4
2806           fac3=-6.0D0*fac3
2807           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2808           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2809           do k=1,3
2810             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2811             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2812           enddo
2813 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2814 cd   &          (dcosg(k),k=1,3)
2815           do k=1,3
2816             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2817      &      fac_shield(i)**2*fac_shield(j)**2
2818           enddo
2819 c          do k=1,3
2820 c            ghalf=0.5D0*ggg(k)
2821 c            gelc(k,i)=gelc(k,i)+ghalf
2822 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2823 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2824 c            gelc(k,j)=gelc(k,j)+ghalf
2825 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2826 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2827 c          enddo
2828 cgrad          do k=i+1,j-1
2829 cgrad            do l=1,3
2830 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2831 cgrad            enddo
2832 cgrad          enddo
2833 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2834           do k=1,3
2835             gelc(k,i)=gelc(k,i)
2836      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2837      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2838      &           *fac_shield(i)**2*fac_shield(j)**2
2839             gelc(k,j)=gelc(k,j)
2840      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2841      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2842      &           *fac_shield(i)**2*fac_shield(j)**2
2843             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2844             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2845           enddo
2846 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2847
2848 C MARYSIA
2849 c          endif !sscale
2850           endif ! calc_grad
2851           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2852      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2853      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2854 C
2855 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2856 C   energy of a peptide unit is assumed in the form of a second-order
2857 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2858 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2859 C   are computed for EVERY pair of non-contiguous peptide groups.
2860 C
2861
2862           if (j.lt.nres-1) then
2863             j1=j+1
2864             j2=j-1
2865           else
2866             j1=j-1
2867             j2=j-2
2868           endif
2869           kkk=0
2870           lll=0
2871           do k=1,2
2872             do l=1,2
2873               kkk=kkk+1
2874               muij(kkk)=mu(k,i)*mu(l,j)
2875 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2876 #ifdef NEWCORR
2877              if (calc_grad) then
2878              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2879 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2880              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2881              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2882 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2883              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2884              endif
2885 #endif
2886             enddo
2887           enddo
2888 #ifdef DEBUG
2889           write (iout,*) 'EELEC: i',i,' j',j
2890           write (iout,*) 'j',j,' j1',j1,' j2',j2
2891           write(iout,*) 'muij',muij
2892           write (iout,*) "uy",uy(:,i)
2893           write (iout,*) "uz",uz(:,j)
2894           write (iout,*) "erij",erij
2895 #endif
2896           ury=scalar(uy(1,i),erij)
2897           urz=scalar(uz(1,i),erij)
2898           vry=scalar(uy(1,j),erij)
2899           vrz=scalar(uz(1,j),erij)
2900           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2901           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2902           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2903           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2904           fac=dsqrt(-ael6i)*r3ij
2905           a22=a22*fac
2906           a23=a23*fac
2907           a32=a32*fac
2908           a33=a33*fac
2909 cd          write (iout,'(4i5,4f10.5)')
2910 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2911 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2912 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2913 cd     &      uy(:,j),uz(:,j)
2914 cd          write (iout,'(4f10.5)')
2915 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2916 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2917 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2918 cd           write (iout,'(9f10.5/)')
2919 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2920 C Derivatives of the elements of A in virtual-bond vectors
2921           if (calc_grad) then
2922           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2923           do k=1,3
2924             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2925             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2926             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2927             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2928             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2929             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2930             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2931             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2932             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2933             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2934             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2935             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2936           enddo
2937 C Compute radial contributions to the gradient
2938           facr=-3.0d0*rrmij
2939           a22der=a22*facr
2940           a23der=a23*facr
2941           a32der=a32*facr
2942           a33der=a33*facr
2943           agg(1,1)=a22der*xj
2944           agg(2,1)=a22der*yj
2945           agg(3,1)=a22der*zj
2946           agg(1,2)=a23der*xj
2947           agg(2,2)=a23der*yj
2948           agg(3,2)=a23der*zj
2949           agg(1,3)=a32der*xj
2950           agg(2,3)=a32der*yj
2951           agg(3,3)=a32der*zj
2952           agg(1,4)=a33der*xj
2953           agg(2,4)=a33der*yj
2954           agg(3,4)=a33der*zj
2955 C Add the contributions coming from er
2956           fac3=-3.0d0*fac
2957           do k=1,3
2958             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2959             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2960             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2961             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2962           enddo
2963           do k=1,3
2964 C Derivatives in DC(i)
2965 cgrad            ghalf1=0.5d0*agg(k,1)
2966 cgrad            ghalf2=0.5d0*agg(k,2)
2967 cgrad            ghalf3=0.5d0*agg(k,3)
2968 cgrad            ghalf4=0.5d0*agg(k,4)
2969             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2970      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2971             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2972      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2973             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2974      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2975             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2976      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2977 C Derivatives in DC(i+1)
2978             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2979      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2980             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2981      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2982             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2983      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2984             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2985      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2986 C Derivatives in DC(j)
2987             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2988      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2989             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2990      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2991             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2992      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2993             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2994      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2995 C Derivatives in DC(j+1) or DC(nres-1)
2996             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2997      &      -3.0d0*vryg(k,3)*ury)
2998             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2999      &      -3.0d0*vrzg(k,3)*ury)
3000             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3001      &      -3.0d0*vryg(k,3)*urz)
3002             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3003      &      -3.0d0*vrzg(k,3)*urz)
3004 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3005 cgrad              do l=1,4
3006 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3007 cgrad              enddo
3008 cgrad            endif
3009           enddo
3010           endif ! calc_grad
3011           acipa(1,1)=a22
3012           acipa(1,2)=a23
3013           acipa(2,1)=a32
3014           acipa(2,2)=a33
3015           a22=-a22
3016           a23=-a23
3017           if (calc_grad) then
3018           do l=1,2
3019             do k=1,3
3020               agg(k,l)=-agg(k,l)
3021               aggi(k,l)=-aggi(k,l)
3022               aggi1(k,l)=-aggi1(k,l)
3023               aggj(k,l)=-aggj(k,l)
3024               aggj1(k,l)=-aggj1(k,l)
3025             enddo
3026           enddo
3027           endif ! calc_grad
3028           if (j.lt.nres-1) then
3029             a22=-a22
3030             a32=-a32
3031             do l=1,3,2
3032               do k=1,3
3033                 agg(k,l)=-agg(k,l)
3034                 aggi(k,l)=-aggi(k,l)
3035                 aggi1(k,l)=-aggi1(k,l)
3036                 aggj(k,l)=-aggj(k,l)
3037                 aggj1(k,l)=-aggj1(k,l)
3038               enddo
3039             enddo
3040           else
3041             a22=-a22
3042             a23=-a23
3043             a32=-a32
3044             a33=-a33
3045             do l=1,4
3046               do k=1,3
3047                 agg(k,l)=-agg(k,l)
3048                 aggi(k,l)=-aggi(k,l)
3049                 aggi1(k,l)=-aggi1(k,l)
3050                 aggj(k,l)=-aggj(k,l)
3051                 aggj1(k,l)=-aggj1(k,l)
3052               enddo
3053             enddo
3054           endif
3055           ENDIF ! WCORR
3056           IF (wel_loc.gt.0.0d0) THEN
3057 C Contribution to the local-electrostatic energy coming from the i-j pair
3058           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3059      &     +a33*muij(4)
3060 #ifdef DEBUG
3061           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3062      &     " a33",a33
3063           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3064      &     " wel_loc",wel_loc
3065 #endif
3066           if (shield_mode.eq.0) then
3067            fac_shield(i)=1.0
3068            fac_shield(j)=1.0
3069 C          else
3070 C           fac_shield(i)=0.4
3071 C           fac_shield(j)=0.6
3072           endif
3073           eel_loc_ij=eel_loc_ij
3074      &    *fac_shield(i)*fac_shield(j)
3075           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3076      &            'eelloc',i,j,eel_loc_ij
3077 c           if (eel_loc_ij.ne.0)
3078 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3079 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3080
3081           eel_loc=eel_loc+eel_loc_ij*sss
3082 C Now derivative over eel_loc
3083           if (calc_grad) then
3084           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3085      &  (shield_mode.gt.0)) then
3086 C          print *,i,j
3087
3088           do ilist=1,ishield_list(i)
3089            iresshield=shield_list(ilist,i)
3090            do k=1,3
3091            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3092      &                                          /fac_shield(i)
3093 C     &      *2.0
3094            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3095      &              rlocshield
3096      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3097             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3098      &      +rlocshield
3099            enddo
3100           enddo
3101           do ilist=1,ishield_list(j)
3102            iresshield=shield_list(ilist,j)
3103            do k=1,3
3104            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3105      &                                       /fac_shield(j)
3106 C     &     *2.0
3107            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3108      &              rlocshield
3109      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3110            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3111      &             +rlocshield
3112
3113            enddo
3114           enddo
3115
3116           do k=1,3
3117             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3118      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3119             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3120      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3121             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3122      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3123             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3124      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3125            enddo
3126            endif
3127
3128
3129 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3130 c     &                     ' eel_loc_ij',eel_loc_ij
3131 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3132 C Calculate patrial derivative for theta angle
3133 #ifdef NEWCORR
3134          geel_loc_ij=(a22*gmuij1(1)
3135      &     +a23*gmuij1(2)
3136      &     +a32*gmuij1(3)
3137      &     +a33*gmuij1(4))
3138      &    *fac_shield(i)*fac_shield(j)*sss
3139 c         write(iout,*) "derivative over thatai"
3140 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3141 c     &   a33*gmuij1(4)
3142          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3143      &      geel_loc_ij*wel_loc
3144 c         write(iout,*) "derivative over thatai-1"
3145 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3146 c     &   a33*gmuij2(4)
3147          geel_loc_ij=
3148      &     a22*gmuij2(1)
3149      &     +a23*gmuij2(2)
3150      &     +a32*gmuij2(3)
3151      &     +a33*gmuij2(4)
3152          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3153      &      geel_loc_ij*wel_loc
3154      &    *fac_shield(i)*fac_shield(j)*sss
3155
3156 c  Derivative over j residue
3157          geel_loc_ji=a22*gmuji1(1)
3158      &     +a23*gmuji1(2)
3159      &     +a32*gmuji1(3)
3160      &     +a33*gmuji1(4)
3161 c         write(iout,*) "derivative over thataj"
3162 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3163 c     &   a33*gmuji1(4)
3164
3165         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3166      &      geel_loc_ji*wel_loc
3167      &    *fac_shield(i)*fac_shield(j)
3168
3169          geel_loc_ji=
3170      &     +a22*gmuji2(1)
3171      &     +a23*gmuji2(2)
3172      &     +a32*gmuji2(3)
3173      &     +a33*gmuji2(4)
3174 c         write(iout,*) "derivative over thataj-1"
3175 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3176 c     &   a33*gmuji2(4)
3177          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3178      &      geel_loc_ji*wel_loc
3179      &    *fac_shield(i)*fac_shield(j)*sss
3180 #endif
3181 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3182
3183 C Partial derivatives in virtual-bond dihedral angles gamma
3184           if (i.gt.1)
3185      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3186      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3187      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3188      &    *fac_shield(i)*fac_shield(j)
3189
3190           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3191      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3192      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3193      &    *fac_shield(i)*fac_shield(j)
3194 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3195           aux=eel_loc_ij/sss*sssgrad*rmij
3196           ggg(1)=aux*xj
3197           ggg(2)=aux*yj
3198           ggg(3)=aux*zj
3199           do l=1,3
3200             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3201      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3202      &    *fac_shield(i)*fac_shield(j)*sss
3203             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3204             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3205 cgrad            ghalf=0.5d0*ggg(l)
3206 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3207 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3208           enddo
3209 cgrad          do k=i+1,j2
3210 cgrad            do l=1,3
3211 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3212 cgrad            enddo
3213 cgrad          enddo
3214 C Remaining derivatives of eello
3215           do l=1,3
3216             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3217      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3218      &    *fac_shield(i)*fac_shield(j)
3219
3220             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3221      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3222      &    *fac_shield(i)*fac_shield(j)
3223
3224             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3225      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3226      &    *fac_shield(i)*fac_shield(j)
3227
3228             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3229      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3230      &    *fac_shield(i)*fac_shield(j)
3231
3232           enddo
3233           endif ! calc_grad
3234           ENDIF
3235
3236
3237 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3238 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3239 #ifdef FOURBODY
3240           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3241      &       .and. num_conti.le.maxconts) then
3242 c            write (iout,*) i,j," entered corr"
3243 C
3244 C Calculate the contact function. The ith column of the array JCONT will
3245 C contain the numbers of atoms that make contacts with the atom I (of numbers
3246 C greater than I). The arrays FACONT and GACONT will contain the values of
3247 C the contact function and its derivative.
3248 c           r0ij=1.02D0*rpp(iteli,itelj)
3249 c           r0ij=1.11D0*rpp(iteli,itelj)
3250             r0ij=2.20D0*rpp(iteli,itelj)
3251 c           r0ij=1.55D0*rpp(iteli,itelj)
3252             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3253             if (fcont.gt.0.0D0) then
3254               num_conti=num_conti+1
3255               if (num_conti.gt.maxconts) then
3256                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3257      &                         ' will skip next contacts for this conf.'
3258               else
3259                 jcont_hb(num_conti,i)=j
3260 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3261 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3262                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3263      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3264 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3265 C  terms.
3266                 d_cont(num_conti,i)=rij
3267 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3268 C     --- Electrostatic-interaction matrix ---
3269                 a_chuj(1,1,num_conti,i)=a22
3270                 a_chuj(1,2,num_conti,i)=a23
3271                 a_chuj(2,1,num_conti,i)=a32
3272                 a_chuj(2,2,num_conti,i)=a33
3273 C     --- Gradient of rij
3274                 if (calc_grad) then
3275                 do kkk=1,3
3276                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3277                 enddo
3278                 kkll=0
3279                 do k=1,2
3280                   do l=1,2
3281                     kkll=kkll+1
3282                     do m=1,3
3283                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3284                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3285                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3286                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3287                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3288                     enddo
3289                   enddo
3290                 enddo
3291                 endif ! calc_grad
3292                 ENDIF
3293                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3294 C Calculate contact energies
3295                 cosa4=4.0D0*cosa
3296                 wij=cosa-3.0D0*cosb*cosg
3297                 cosbg1=cosb+cosg
3298                 cosbg2=cosb-cosg
3299 c               fac3=dsqrt(-ael6i)/r0ij**3
3300                 fac3=dsqrt(-ael6i)*r3ij
3301 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3302                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3303                 if (ees0tmp.gt.0) then
3304                   ees0pij=dsqrt(ees0tmp)
3305                 else
3306                   ees0pij=0
3307                 endif
3308 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3309                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3310                 if (ees0tmp.gt.0) then
3311                   ees0mij=dsqrt(ees0tmp)
3312                 else
3313                   ees0mij=0
3314                 endif
3315 c               ees0mij=0.0D0
3316                 if (shield_mode.eq.0) then
3317                 fac_shield(i)=1.0d0
3318                 fac_shield(j)=1.0d0
3319                 else
3320                 ees0plist(num_conti,i)=j
3321 C                fac_shield(i)=0.4d0
3322 C                fac_shield(j)=0.6d0
3323                 endif
3324                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3325      &          *fac_shield(i)*fac_shield(j)
3326                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3327      &          *fac_shield(i)*fac_shield(j)
3328 C Diagnostics. Comment out or remove after debugging!
3329 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3330 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3331 c               ees0m(num_conti,i)=0.0D0
3332 C End diagnostics.
3333 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3334 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3335 C Angular derivatives of the contact function
3336
3337                 ees0pij1=fac3/ees0pij
3338                 ees0mij1=fac3/ees0mij
3339                 fac3p=-3.0D0*fac3*rrmij
3340                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3341                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3342 c               ees0mij1=0.0D0
3343                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3344                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3345                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3346                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3347                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3348                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3349                 ecosap=ecosa1+ecosa2
3350                 ecosbp=ecosb1+ecosb2
3351                 ecosgp=ecosg1+ecosg2
3352                 ecosam=ecosa1-ecosa2
3353                 ecosbm=ecosb1-ecosb2
3354                 ecosgm=ecosg1-ecosg2
3355 C Diagnostics
3356 c               ecosap=ecosa1
3357 c               ecosbp=ecosb1
3358 c               ecosgp=ecosg1
3359 c               ecosam=0.0D0
3360 c               ecosbm=0.0D0
3361 c               ecosgm=0.0D0
3362 C End diagnostics
3363                 facont_hb(num_conti,i)=fcont
3364
3365                 if (calc_grad) then
3366                 fprimcont=fprimcont/rij
3367 cd              facont_hb(num_conti,i)=1.0D0
3368 C Following line is for diagnostics.
3369 cd              fprimcont=0.0D0
3370                 do k=1,3
3371                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3372                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3373                 enddo
3374                 do k=1,3
3375                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3376                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3377                 enddo
3378                 gggp(1)=gggp(1)+ees0pijp*xj
3379      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3380                 gggp(2)=gggp(2)+ees0pijp*yj
3381      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3382                 gggp(3)=gggp(3)+ees0pijp*zj
3383      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3384                 gggm(1)=gggm(1)+ees0mijp*xj
3385      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3386                 gggm(2)=gggm(2)+ees0mijp*yj
3387      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3388                 gggm(3)=gggm(3)+ees0mijp*zj
3389      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3390 C Derivatives due to the contact function
3391                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3392                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3393                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3394                 do k=1,3
3395 c
3396 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3397 c          following the change of gradient-summation algorithm.
3398 c
3399 cgrad                  ghalfp=0.5D0*gggp(k)
3400 cgrad                  ghalfm=0.5D0*gggm(k)
3401                   gacontp_hb1(k,num_conti,i)=!ghalfp
3402      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3403      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3404      &          *fac_shield(i)*fac_shield(j)*sss
3405
3406                   gacontp_hb2(k,num_conti,i)=!ghalfp
3407      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3408      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3409      &          *fac_shield(i)*fac_shield(j)*sss
3410
3411                   gacontp_hb3(k,num_conti,i)=gggp(k)
3412      &          *fac_shield(i)*fac_shield(j)*sss
3413
3414                   gacontm_hb1(k,num_conti,i)=!ghalfm
3415      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3416      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3417      &          *fac_shield(i)*fac_shield(j)*sss
3418
3419                   gacontm_hb2(k,num_conti,i)=!ghalfm
3420      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3421      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3422      &          *fac_shield(i)*fac_shield(j)*sss
3423
3424                   gacontm_hb3(k,num_conti,i)=gggm(k)
3425      &          *fac_shield(i)*fac_shield(j)
3426 *sss
3427                 enddo
3428 C Diagnostics. Comment out or remove after debugging!
3429 cdiag           do k=1,3
3430 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3431 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3432 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3433 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3434 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3435 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3436 cdiag           enddo
3437
3438                  endif ! calc_grad
3439
3440               ENDIF ! wcorr
3441               endif  ! num_conti.le.maxconts
3442             endif  ! fcont.gt.0
3443           endif    ! j.gt.i+1
3444 #endif
3445           if (calc_grad) then
3446           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3447             do k=1,4
3448               do l=1,3
3449                 ghalf=0.5d0*agg(l,k)
3450                 aggi(l,k)=aggi(l,k)+ghalf
3451                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3452                 aggj(l,k)=aggj(l,k)+ghalf
3453               enddo
3454             enddo
3455             if (j.eq.nres-1 .and. i.lt.j-2) then
3456               do k=1,4
3457                 do l=1,3
3458                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3459                 enddo
3460               enddo
3461             endif
3462           endif
3463           endif ! calc_grad
3464 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3465       return
3466       end
3467 C-----------------------------------------------------------------------------
3468       subroutine eturn3(i,eello_turn3)
3469 C Third- and fourth-order contributions from turns
3470       implicit real*8 (a-h,o-z)
3471       include 'DIMENSIONS'
3472       include 'COMMON.IOUNITS'
3473       include 'COMMON.GEO'
3474       include 'COMMON.VAR'
3475       include 'COMMON.LOCAL'
3476       include 'COMMON.CHAIN'
3477       include 'COMMON.DERIV'
3478       include 'COMMON.INTERACT'
3479       include 'COMMON.CONTACTS'
3480       include 'COMMON.TORSION'
3481       include 'COMMON.VECTORS'
3482       include 'COMMON.FFIELD'
3483       include 'COMMON.CONTROL'
3484       include 'COMMON.SHIELD'
3485       dimension ggg(3)
3486       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3487      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3488      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3489      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3490      &  auxgmat2(2,2),auxgmatt2(2,2)
3491       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3492      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3493       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3494      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3495      &    num_conti,j1,j2
3496       j=i+2
3497 c      write (iout,*) "eturn3",i,j,j1,j2
3498       a_temp(1,1)=a22
3499       a_temp(1,2)=a23
3500       a_temp(2,1)=a32
3501       a_temp(2,2)=a33
3502 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3503 C
3504 C               Third-order contributions
3505 C
3506 C                 (i+2)o----(i+3)
3507 C                      | |
3508 C                      | |
3509 C                 (i+1)o----i
3510 C
3511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3512 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3513         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3514 c auxalary matices for theta gradient
3515 c auxalary matrix for i+1 and constant i+2
3516         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3517 c auxalary matrix for i+2 and constant i+1
3518         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3519         call transpose2(auxmat(1,1),auxmat1(1,1))
3520         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3521         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3522         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3523         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3524         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3525         if (shield_mode.eq.0) then
3526         fac_shield(i)=1.0
3527         fac_shield(j)=1.0
3528 C        else
3529 C        fac_shield(i)=0.4
3530 C        fac_shield(j)=0.6
3531         endif
3532         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3533      &  *fac_shield(i)*fac_shield(j)
3534         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3535      &  *fac_shield(i)*fac_shield(j)
3536         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3537      &    eello_t3
3538         if (calc_grad) then
3539 C#ifdef NEWCORR
3540 C Derivatives in theta
3541         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3542      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3543      &   *fac_shield(i)*fac_shield(j)
3544         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3545      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3546      &   *fac_shield(i)*fac_shield(j)
3547 C#endif
3548
3549 C Derivatives in shield mode
3550           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3551      &  (shield_mode.gt.0)) then
3552 C          print *,i,j
3553
3554           do ilist=1,ishield_list(i)
3555            iresshield=shield_list(ilist,i)
3556            do k=1,3
3557            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3558 C     &      *2.0
3559            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3560      &              rlocshield
3561      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3562             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3563      &      +rlocshield
3564            enddo
3565           enddo
3566           do ilist=1,ishield_list(j)
3567            iresshield=shield_list(ilist,j)
3568            do k=1,3
3569            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3570 C     &     *2.0
3571            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3572      &              rlocshield
3573      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3574            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3575      &             +rlocshield
3576
3577            enddo
3578           enddo
3579
3580           do k=1,3
3581             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3582      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3583             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3584      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3585             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3586      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3587             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3588      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3589            enddo
3590            endif
3591
3592 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3593 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3594 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3595 cd     &    ' eello_turn3_num',4*eello_turn3_num
3596 C Derivatives in gamma(i)
3597         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3598         call transpose2(auxmat2(1,1),auxmat3(1,1))
3599         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3600         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3601      &   *fac_shield(i)*fac_shield(j)
3602 C Derivatives in gamma(i+1)
3603         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3604         call transpose2(auxmat2(1,1),auxmat3(1,1))
3605         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3606         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3607      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3608      &   *fac_shield(i)*fac_shield(j)
3609 C Cartesian derivatives
3610         do l=1,3
3611 c            ghalf1=0.5d0*agg(l,1)
3612 c            ghalf2=0.5d0*agg(l,2)
3613 c            ghalf3=0.5d0*agg(l,3)
3614 c            ghalf4=0.5d0*agg(l,4)
3615           a_temp(1,1)=aggi(l,1)!+ghalf1
3616           a_temp(1,2)=aggi(l,2)!+ghalf2
3617           a_temp(2,1)=aggi(l,3)!+ghalf3
3618           a_temp(2,2)=aggi(l,4)!+ghalf4
3619           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3620           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3621      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3622      &   *fac_shield(i)*fac_shield(j)
3623
3624           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3625           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3626           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3627           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3628           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3629           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3630      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3631      &   *fac_shield(i)*fac_shield(j)
3632           a_temp(1,1)=aggj(l,1)!+ghalf1
3633           a_temp(1,2)=aggj(l,2)!+ghalf2
3634           a_temp(2,1)=aggj(l,3)!+ghalf3
3635           a_temp(2,2)=aggj(l,4)!+ghalf4
3636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3637           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3639      &   *fac_shield(i)*fac_shield(j)
3640           a_temp(1,1)=aggj1(l,1)
3641           a_temp(1,2)=aggj1(l,2)
3642           a_temp(2,1)=aggj1(l,3)
3643           a_temp(2,2)=aggj1(l,4)
3644           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3645           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3646      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3647      &   *fac_shield(i)*fac_shield(j)
3648         enddo
3649
3650         endif ! calc_grad
3651
3652       return
3653       end
3654 C-------------------------------------------------------------------------------
3655       subroutine eturn4(i,eello_turn4)
3656 C Third- and fourth-order contributions from turns
3657       implicit real*8 (a-h,o-z)
3658       include 'DIMENSIONS'
3659       include 'COMMON.IOUNITS'
3660       include 'COMMON.GEO'
3661       include 'COMMON.VAR'
3662       include 'COMMON.LOCAL'
3663       include 'COMMON.CHAIN'
3664       include 'COMMON.DERIV'
3665       include 'COMMON.INTERACT'
3666       include 'COMMON.CONTACTS'
3667       include 'COMMON.TORSION'
3668       include 'COMMON.VECTORS'
3669       include 'COMMON.FFIELD'
3670       include 'COMMON.CONTROL'
3671       include 'COMMON.SHIELD'
3672       dimension ggg(3)
3673       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3674      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3675      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3676      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3677      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3678      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3679      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3680       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3681      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3682       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3683      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3684      &    num_conti,j1,j2
3685       j=i+3
3686 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3687 C
3688 C               Fourth-order contributions
3689 C
3690 C                 (i+3)o----(i+4)
3691 C                     /  |
3692 C               (i+2)o   |
3693 C                     \  |
3694 C                 (i+1)o----i
3695 C
3696 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3697 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3698 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3699 c        write(iout,*)"WCHODZE W PROGRAM"
3700         a_temp(1,1)=a22
3701         a_temp(1,2)=a23
3702         a_temp(2,1)=a32
3703         a_temp(2,2)=a33
3704         iti1=itype2loc(itype(i+1))
3705         iti2=itype2loc(itype(i+2))
3706         iti3=itype2loc(itype(i+3))
3707 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3708         call transpose2(EUg(1,1,i+1),e1t(1,1))
3709         call transpose2(Eug(1,1,i+2),e2t(1,1))
3710         call transpose2(Eug(1,1,i+3),e3t(1,1))
3711 C Ematrix derivative in theta
3712         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3713         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3714         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3715         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3716 c       eta1 in derivative theta
3717         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3718         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3719 c       auxgvec is derivative of Ub2 so i+3 theta
3720         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3721 c       auxalary matrix of E i+1
3722         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3723 c        s1=0.0
3724 c        gs1=0.0
3725         s1=scalar2(b1(1,i+2),auxvec(1))
3726 c derivative of theta i+2 with constant i+3
3727         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3728 c derivative of theta i+2 with constant i+2
3729         gs32=scalar2(b1(1,i+2),auxgvec(1))
3730 c derivative of E matix in theta of i+1
3731         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3732
3733         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3734 c       ea31 in derivative theta
3735         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3736         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3737 c auxilary matrix auxgvec of Ub2 with constant E matirx
3738         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3739 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3740         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3741
3742 c        s2=0.0
3743 c        gs2=0.0
3744         s2=scalar2(b1(1,i+1),auxvec(1))
3745 c derivative of theta i+1 with constant i+3
3746         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3747 c derivative of theta i+2 with constant i+1
3748         gs21=scalar2(b1(1,i+1),auxgvec(1))
3749 c derivative of theta i+3 with constant i+1
3750         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3751 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3752 c     &  gtb1(1,i+1)
3753         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3754 c two derivatives over diffetent matrices
3755 c gtae3e2 is derivative over i+3
3756         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3757 c ae3gte2 is derivative over i+2
3758         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3759         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3760 c three possible derivative over theta E matices
3761 c i+1
3762         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3763 c i+2
3764         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3765 c i+3
3766         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3767         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3768
3769         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3770         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3771         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3772         if (shield_mode.eq.0) then
3773         fac_shield(i)=1.0
3774         fac_shield(j)=1.0
3775 C        else
3776 C        fac_shield(i)=0.6
3777 C        fac_shield(j)=0.4
3778         endif
3779         eello_turn4=eello_turn4-(s1+s2+s3)
3780      &  *fac_shield(i)*fac_shield(j)
3781         eello_t4=-(s1+s2+s3)
3782      &  *fac_shield(i)*fac_shield(j)
3783 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3784         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3785      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3786 C Now derivative over shield:
3787           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3788      &  (shield_mode.gt.0)) then
3789 C          print *,i,j
3790
3791           do ilist=1,ishield_list(i)
3792            iresshield=shield_list(ilist,i)
3793            do k=1,3
3794            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3795 C     &      *2.0
3796            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3797      &              rlocshield
3798      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3799             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3800      &      +rlocshield
3801            enddo
3802           enddo
3803           do ilist=1,ishield_list(j)
3804            iresshield=shield_list(ilist,j)
3805            do k=1,3
3806            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3807 C     &     *2.0
3808            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3809      &              rlocshield
3810      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3811            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3812      &             +rlocshield
3813
3814            enddo
3815           enddo
3816
3817           do k=1,3
3818             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3819      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3820             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3821      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3822             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3823      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3824             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3825      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3826            enddo
3827            endif
3828 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3829 cd     &    ' eello_turn4_num',8*eello_turn4_num
3830 #ifdef NEWCORR
3831         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3832      &                  -(gs13+gsE13+gsEE1)*wturn4
3833      &  *fac_shield(i)*fac_shield(j)
3834         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3835      &                    -(gs23+gs21+gsEE2)*wturn4
3836      &  *fac_shield(i)*fac_shield(j)
3837
3838         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3839      &                    -(gs32+gsE31+gsEE3)*wturn4
3840      &  *fac_shield(i)*fac_shield(j)
3841
3842 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3843 c     &   gs2
3844 #endif
3845         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3846      &      'eturn4',i,j,-(s1+s2+s3)
3847 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3848 c     &    ' eello_turn4_num',8*eello_turn4_num
3849 C Derivatives in gamma(i)
3850         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3851         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3852         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3853         s1=scalar2(b1(1,i+2),auxvec(1))
3854         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3855         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3856         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3857      &  *fac_shield(i)*fac_shield(j)
3858 C Derivatives in gamma(i+1)
3859         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3860         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3861         s2=scalar2(b1(1,i+1),auxvec(1))
3862         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3863         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3864         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3865         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3866      &  *fac_shield(i)*fac_shield(j)
3867 C Derivatives in gamma(i+2)
3868         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3869         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3870         s1=scalar2(b1(1,i+2),auxvec(1))
3871         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3872         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3873         s2=scalar2(b1(1,i+1),auxvec(1))
3874         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3875         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3876         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3877         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3878      &  *fac_shield(i)*fac_shield(j)
3879         if (calc_grad) then
3880 C Cartesian derivatives
3881 C Derivatives of this turn contributions in DC(i+2)
3882         if (j.lt.nres-1) then
3883           do l=1,3
3884             a_temp(1,1)=agg(l,1)
3885             a_temp(1,2)=agg(l,2)
3886             a_temp(2,1)=agg(l,3)
3887             a_temp(2,2)=agg(l,4)
3888             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3889             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3890             s1=scalar2(b1(1,i+2),auxvec(1))
3891             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3892             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3893             s2=scalar2(b1(1,i+1),auxvec(1))
3894             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3895             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3896             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897             ggg(l)=-(s1+s2+s3)
3898             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3899      &  *fac_shield(i)*fac_shield(j)
3900           enddo
3901         endif
3902 C Remaining derivatives of this turn contribution
3903         do l=1,3
3904           a_temp(1,1)=aggi(l,1)
3905           a_temp(1,2)=aggi(l,2)
3906           a_temp(2,1)=aggi(l,3)
3907           a_temp(2,2)=aggi(l,4)
3908           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3909           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3910           s1=scalar2(b1(1,i+2),auxvec(1))
3911           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3912           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3913           s2=scalar2(b1(1,i+1),auxvec(1))
3914           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3915           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3916           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3917           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3918      &  *fac_shield(i)*fac_shield(j)
3919           a_temp(1,1)=aggi1(l,1)
3920           a_temp(1,2)=aggi1(l,2)
3921           a_temp(2,1)=aggi1(l,3)
3922           a_temp(2,2)=aggi1(l,4)
3923           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3924           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3925           s1=scalar2(b1(1,i+2),auxvec(1))
3926           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3927           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3928           s2=scalar2(b1(1,i+1),auxvec(1))
3929           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3930           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3931           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3932           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3933      &  *fac_shield(i)*fac_shield(j)
3934           a_temp(1,1)=aggj(l,1)
3935           a_temp(1,2)=aggj(l,2)
3936           a_temp(2,1)=aggj(l,3)
3937           a_temp(2,2)=aggj(l,4)
3938           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3939           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3940           s1=scalar2(b1(1,i+2),auxvec(1))
3941           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3942           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3943           s2=scalar2(b1(1,i+1),auxvec(1))
3944           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3945           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3946           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3947           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3948      &  *fac_shield(i)*fac_shield(j)
3949           a_temp(1,1)=aggj1(l,1)
3950           a_temp(1,2)=aggj1(l,2)
3951           a_temp(2,1)=aggj1(l,3)
3952           a_temp(2,2)=aggj1(l,4)
3953           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3954           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3955           s1=scalar2(b1(1,i+2),auxvec(1))
3956           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3957           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3958           s2=scalar2(b1(1,i+1),auxvec(1))
3959           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3960           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3961           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3962 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3963           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3964      &  *fac_shield(i)*fac_shield(j)
3965         enddo
3966
3967         endif ! calc_grad
3968
3969       return
3970       end
3971 C-----------------------------------------------------------------------------
3972       subroutine vecpr(u,v,w)
3973       implicit real*8(a-h,o-z)
3974       dimension u(3),v(3),w(3)
3975       w(1)=u(2)*v(3)-u(3)*v(2)
3976       w(2)=-u(1)*v(3)+u(3)*v(1)
3977       w(3)=u(1)*v(2)-u(2)*v(1)
3978       return
3979       end
3980 C-----------------------------------------------------------------------------
3981       subroutine unormderiv(u,ugrad,unorm,ungrad)
3982 C This subroutine computes the derivatives of a normalized vector u, given
3983 C the derivatives computed without normalization conditions, ugrad. Returns
3984 C ungrad.
3985       implicit none
3986       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3987       double precision vec(3)
3988       double precision scalar
3989       integer i,j
3990 c      write (2,*) 'ugrad',ugrad
3991 c      write (2,*) 'u',u
3992       do i=1,3
3993         vec(i)=scalar(ugrad(1,i),u(1))
3994       enddo
3995 c      write (2,*) 'vec',vec
3996       do i=1,3
3997         do j=1,3
3998           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3999         enddo
4000       enddo
4001 c      write (2,*) 'ungrad',ungrad
4002       return
4003       end
4004 C-----------------------------------------------------------------------------
4005       subroutine escp(evdw2,evdw2_14)
4006 C
4007 C This subroutine calculates the excluded-volume interaction energy between
4008 C peptide-group centers and side chains and its gradient in virtual-bond and
4009 C side-chain vectors.
4010 C
4011       implicit real*8 (a-h,o-z)
4012       include 'DIMENSIONS'
4013       include 'COMMON.GEO'
4014       include 'COMMON.VAR'
4015       include 'COMMON.LOCAL'
4016       include 'COMMON.CHAIN'
4017       include 'COMMON.DERIV'
4018       include 'COMMON.INTERACT'
4019       include 'COMMON.FFIELD'
4020       include 'COMMON.IOUNITS'
4021       dimension ggg(3)
4022       evdw2=0.0D0
4023       evdw2_14=0.0d0
4024 cd    print '(a)','Enter ESCP'
4025 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4026 c     &  ' scal14',scal14
4027       do i=iatscp_s,iatscp_e
4028         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4029         iteli=itel(i)
4030 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4031 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4032         if (iteli.eq.0) goto 1225
4033         xi=0.5D0*(c(1,i)+c(1,i+1))
4034         yi=0.5D0*(c(2,i)+c(2,i+1))
4035         zi=0.5D0*(c(3,i)+c(3,i+1))
4036 C Returning the ith atom to box
4037           xi=mod(xi,boxxsize)
4038           if (xi.lt.0) xi=xi+boxxsize
4039           yi=mod(yi,boxysize)
4040           if (yi.lt.0) yi=yi+boxysize
4041           zi=mod(zi,boxzsize)
4042           if (zi.lt.0) zi=zi+boxzsize
4043         do iint=1,nscp_gr(i)
4044
4045         do j=iscpstart(i,iint),iscpend(i,iint)
4046           itypj=iabs(itype(j))
4047           if (itypj.eq.ntyp1) cycle
4048 C Uncomment following three lines for SC-p interactions
4049 c         xj=c(1,nres+j)-xi
4050 c         yj=c(2,nres+j)-yi
4051 c         zj=c(3,nres+j)-zi
4052 C Uncomment following three lines for Ca-p interactions
4053           xj=c(1,j)
4054           yj=c(2,j)
4055           zj=c(3,j)
4056 C returning the jth atom to box
4057           xj=mod(xj,boxxsize)
4058           if (xj.lt.0) xj=xj+boxxsize
4059           yj=mod(yj,boxysize)
4060           if (yj.lt.0) yj=yj+boxysize
4061           zj=mod(zj,boxzsize)
4062           if (zj.lt.0) zj=zj+boxzsize
4063       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4064       xj_safe=xj
4065       yj_safe=yj
4066       zj_safe=zj
4067       subchap=0
4068 C Finding the closest jth atom
4069       do xshift=-1,1
4070       do yshift=-1,1
4071       do zshift=-1,1
4072           xj=xj_safe+xshift*boxxsize
4073           yj=yj_safe+yshift*boxysize
4074           zj=zj_safe+zshift*boxzsize
4075           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4076           if(dist_temp.lt.dist_init) then
4077             dist_init=dist_temp
4078             xj_temp=xj
4079             yj_temp=yj
4080             zj_temp=zj
4081             subchap=1
4082           endif
4083        enddo
4084        enddo
4085        enddo
4086        if (subchap.eq.1) then
4087           xj=xj_temp-xi
4088           yj=yj_temp-yi
4089           zj=zj_temp-zi
4090        else
4091           xj=xj_safe-xi
4092           yj=yj_safe-yi
4093           zj=zj_safe-zi
4094        endif
4095           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4096 C sss is scaling function for smoothing the cutoff gradient otherwise
4097 C the gradient would not be continuouse
4098           sss=sscale(1.0d0/(dsqrt(rrij)))
4099           if (sss.le.0.0d0) cycle
4100           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4101           fac=rrij**expon2
4102           e1=fac*fac*aad(itypj,iteli)
4103           e2=fac*bad(itypj,iteli)
4104           if (iabs(j-i) .le. 2) then
4105             e1=scal14*e1
4106             e2=scal14*e2
4107             evdw2_14=evdw2_14+(e1+e2)*sss
4108           endif
4109           evdwij=e1+e2
4110 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4111 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4112 c     &       bad(itypj,iteli)
4113           evdw2=evdw2+evdwij*sss
4114           if (calc_grad) then
4115 C
4116 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4117 C
4118           fac=-(evdwij+e1)*rrij*sss
4119           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4120           ggg(1)=xj*fac
4121           ggg(2)=yj*fac
4122           ggg(3)=zj*fac
4123           if (j.lt.i) then
4124 cd          write (iout,*) 'j<i'
4125 C Uncomment following three lines for SC-p interactions
4126 c           do k=1,3
4127 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4128 c           enddo
4129           else
4130 cd          write (iout,*) 'j>i'
4131             do k=1,3
4132               ggg(k)=-ggg(k)
4133 C Uncomment following line for SC-p interactions
4134 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4135             enddo
4136           endif
4137           do k=1,3
4138             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4139           enddo
4140           kstart=min0(i+1,j)
4141           kend=max0(i-1,j-1)
4142 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4143 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4144           do k=kstart,kend
4145             do l=1,3
4146               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4147             enddo
4148           enddo
4149           endif ! calc_grad
4150         enddo
4151         enddo ! iint
4152  1225   continue
4153       enddo ! i
4154       do i=1,nct
4155         do j=1,3
4156           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4157           gradx_scp(j,i)=expon*gradx_scp(j,i)
4158         enddo
4159       enddo
4160 C******************************************************************************
4161 C
4162 C                              N O T E !!!
4163 C
4164 C To save time the factor EXPON has been extracted from ALL components
4165 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4166 C use!
4167 C
4168 C******************************************************************************
4169       return
4170       end
4171 C--------------------------------------------------------------------------
4172       subroutine edis(ehpb)
4173 C
4174 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4175 C
4176       implicit real*8 (a-h,o-z)
4177       include 'DIMENSIONS'
4178       include 'COMMON.SBRIDGE'
4179       include 'COMMON.CHAIN'
4180       include 'COMMON.DERIV'
4181       include 'COMMON.VAR'
4182       include 'COMMON.INTERACT'
4183       include 'COMMON.CONTROL'
4184       include 'COMMON.IOUNITS'
4185       dimension ggg(3),ggg_peak(3,1000)
4186       ehpb=0.0D0
4187       ggg=0.0d0
4188 c 8/21/18 AL: added explicit restraints on reference coords
4189 c      write (iout,*) "restr_on_coord",restr_on_coord
4190       if (restr_on_coord) then
4191
4192       do i=nnt,nct
4193         ecoor=0.0d0
4194         if (itype(i).eq.ntyp1) cycle
4195         do j=1,3
4196           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4197           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4198         enddo
4199         if (itype(i).ne.10) then
4200           do j=1,3
4201             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4202             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4203           enddo
4204         endif
4205         if (energy_dec) write (iout,*)
4206      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4207         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4208       enddo
4209
4210       endif
4211 C      write (iout,*) ,"link_end",link_end,constr_dist
4212 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4213 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4214 c     &  " constr_dist",constr_dist
4215       if (link_end.eq.0.and.link_end_peak.eq.0) return
4216       do i=link_start_peak,link_end_peak
4217         ehpb_peak=0.0d0
4218 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4219 c     &   ipeak(1,i),ipeak(2,i)
4220         do ip=ipeak(1,i),ipeak(2,i)
4221           ii=ihpb_peak(ip)
4222           jj=jhpb_peak(ip)
4223           dd=dist(ii,jj)
4224           iip=ip-ipeak(1,i)+1
4225 C iii and jjj point to the residues for which the distance is assigned.
4226 c          if (ii.gt.nres) then
4227 c            iii=ii-nres
4228 c            jjj=jj-nres
4229 c          else
4230 c            iii=ii
4231 c            jjj=jj
4232 c          endif
4233           if (ii.gt.nres) then
4234             iii=ii-nres
4235           else
4236             iii=ii
4237           endif
4238           if (jj.gt.nres) then
4239             jjj=jj-nres
4240           else
4241             jjj=jj
4242           endif
4243           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4244           aux=dexp(-scal_peak*aux)
4245           ehpb_peak=ehpb_peak+aux
4246           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4247      &      forcon_peak(ip))*aux/dd
4248           do j=1,3
4249             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4250           enddo
4251           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4252      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4253      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4254         enddo
4255 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4256         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4257         do ip=ipeak(1,i),ipeak(2,i)
4258           iip=ip-ipeak(1,i)+1
4259           do j=1,3
4260             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4261           enddo
4262           ii=ihpb_peak(ip)
4263           jj=jhpb_peak(ip)
4264 C iii and jjj point to the residues for which the distance is assigned.
4265 c          if (ii.gt.nres) then
4266 c            iii=ii-nres
4267 c            jjj=jj-nres
4268 c          else
4269 c            iii=ii
4270 c            jjj=jj
4271 c          endif
4272           if (ii.gt.nres) then
4273             iii=ii-nres
4274           else
4275             iii=ii
4276           endif
4277           if (jj.gt.nres) then
4278             jjj=jj-nres
4279           else
4280             jjj=jj
4281           endif
4282           if (iii.lt.ii) then
4283             do j=1,3
4284               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4285             enddo
4286           endif
4287           if (jjj.lt.jj) then
4288             do j=1,3
4289               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4290             enddo
4291           endif
4292           do k=1,3
4293             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4294             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4295           enddo
4296         enddo
4297       enddo
4298       do i=link_start,link_end
4299 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4300 C CA-CA distance used in regularization of structure.
4301         ii=ihpb(i)
4302         jj=jhpb(i)
4303 C iii and jjj point to the residues for which the distance is assigned.
4304 c        if (ii.gt.nres) then
4305 c          iii=ii-nres
4306 c          jjj=jj-nres
4307 c        else
4308 c          iii=ii
4309 c          jjj=jj
4310 c        endif
4311         if (ii.gt.nres) then
4312           iii=ii-nres
4313         else
4314           iii=ii
4315         endif
4316         if (jj.gt.nres) then
4317           jjj=jj-nres
4318         else
4319           jjj=jj
4320         endif
4321 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4322 c     &    dhpb(i),dhpb1(i),forcon(i)
4323 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4324 C    distance and angle dependent SS bond potential.
4325 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4326 C     & iabs(itype(jjj)).eq.1) then
4327 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4328 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4329         if (.not.dyn_ss .and. i.le.nss) then
4330 C 15/02/13 CC dynamic SSbond - additional check
4331           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4332      &        iabs(itype(jjj)).eq.1) then
4333            call ssbond_ene(iii,jjj,eij)
4334            ehpb=ehpb+2*eij
4335          endif
4336 cd          write (iout,*) "eij",eij
4337 cd   &   ' waga=',waga,' fac=',fac
4338 !        else if (ii.gt.nres .and. jj.gt.nres) then
4339         else
4340 C Calculate the distance between the two points and its difference from the
4341 C target distance.
4342           dd=dist(ii,jj)
4343           if (irestr_type(i).eq.11) then
4344             ehpb=ehpb+fordepth(i)!**4.0d0
4345      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4346             fac=fordepth(i)!**4.0d0
4347      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4348             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4349      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4350      &        ehpb,irestr_type(i)
4351           else if (irestr_type(i).eq.10) then
4352 c AL 6//19/2018 cross-link restraints
4353             xdis = 0.5d0*(dd/forcon(i))**2
4354             expdis = dexp(-xdis)
4355 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4356             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4357 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4358 c     &          " wboltzd",wboltzd
4359             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4360 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4361             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4362      &           *expdis/(aux*forcon(i)**2)
4363             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4364      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4365      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4366           else if (irestr_type(i).eq.2) then
4367 c Quartic restraints
4368             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4369             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4370      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4371      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4372             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4373           else
4374 c Quadratic restraints
4375             rdis=dd-dhpb(i)
4376 C Get the force constant corresponding to this distance.
4377             waga=forcon(i)
4378 C Calculate the contribution to energy.
4379             ehpb=ehpb+0.5d0*waga*rdis*rdis
4380             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4381      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4382      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4383 C
4384 C Evaluate gradient.
4385 C
4386             fac=waga*rdis/dd
4387           endif
4388 c Calculate Cartesian gradient
4389           do j=1,3
4390             ggg(j)=fac*(c(j,jj)-c(j,ii))
4391           enddo
4392 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4393 C If this is a SC-SC distance, we need to calculate the contributions to the
4394 C Cartesian gradient in the SC vectors (ghpbx).
4395           if (iii.lt.ii) then
4396             do j=1,3
4397               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4398             enddo
4399           endif
4400           if (jjj.lt.jj) then
4401             do j=1,3
4402               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4403             enddo
4404           endif
4405           do k=1,3
4406             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4407             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4408           enddo
4409         endif
4410       enddo
4411       return
4412       end
4413 C--------------------------------------------------------------------------
4414       subroutine ssbond_ene(i,j,eij)
4415 C
4416 C Calculate the distance and angle dependent SS-bond potential energy
4417 C using a free-energy function derived based on RHF/6-31G** ab initio
4418 C calculations of diethyl disulfide.
4419 C
4420 C A. Liwo and U. Kozlowska, 11/24/03
4421 C
4422       implicit real*8 (a-h,o-z)
4423       include 'DIMENSIONS'
4424       include 'COMMON.SBRIDGE'
4425       include 'COMMON.CHAIN'
4426       include 'COMMON.DERIV'
4427       include 'COMMON.LOCAL'
4428       include 'COMMON.INTERACT'
4429       include 'COMMON.VAR'
4430       include 'COMMON.IOUNITS'
4431       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4432       itypi=iabs(itype(i))
4433       xi=c(1,nres+i)
4434       yi=c(2,nres+i)
4435       zi=c(3,nres+i)
4436       dxi=dc_norm(1,nres+i)
4437       dyi=dc_norm(2,nres+i)
4438       dzi=dc_norm(3,nres+i)
4439       dsci_inv=dsc_inv(itypi)
4440       itypj=iabs(itype(j))
4441       dscj_inv=dsc_inv(itypj)
4442       xj=c(1,nres+j)-xi
4443       yj=c(2,nres+j)-yi
4444       zj=c(3,nres+j)-zi
4445       dxj=dc_norm(1,nres+j)
4446       dyj=dc_norm(2,nres+j)
4447       dzj=dc_norm(3,nres+j)
4448       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4449       rij=dsqrt(rrij)
4450       erij(1)=xj*rij
4451       erij(2)=yj*rij
4452       erij(3)=zj*rij
4453       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4454       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4455       om12=dxi*dxj+dyi*dyj+dzi*dzj
4456       do k=1,3
4457         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4458         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4459       enddo
4460       rij=1.0d0/rij
4461       deltad=rij-d0cm
4462       deltat1=1.0d0-om1
4463       deltat2=1.0d0+om2
4464       deltat12=om2-om1+2.0d0
4465       cosphi=om12-om1*om2
4466       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4467      &  +akct*deltad*deltat12
4468      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4469 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4470 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4471 c     &  " deltat12",deltat12," eij",eij
4472       ed=2*akcm*deltad+akct*deltat12
4473       pom1=akct*deltad
4474       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4475       eom1=-2*akth*deltat1-pom1-om2*pom2
4476       eom2= 2*akth*deltat2+pom1-om1*pom2
4477       eom12=pom2
4478       do k=1,3
4479         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4480       enddo
4481       do k=1,3
4482         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4483      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4484         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4485      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4486       enddo
4487 C
4488 C Calculate the components of the gradient in DC and X
4489 C
4490       do k=i,j-1
4491         do l=1,3
4492           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4493         enddo
4494       enddo
4495       return
4496       end
4497 C--------------------------------------------------------------------------
4498       subroutine ebond(estr)
4499 c
4500 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4501 c
4502       implicit real*8 (a-h,o-z)
4503       include 'DIMENSIONS'
4504       include 'COMMON.LOCAL'
4505       include 'COMMON.GEO'
4506       include 'COMMON.INTERACT'
4507       include 'COMMON.DERIV'
4508       include 'COMMON.VAR'
4509       include 'COMMON.CHAIN'
4510       include 'COMMON.IOUNITS'
4511       include 'COMMON.NAMES'
4512       include 'COMMON.FFIELD'
4513       include 'COMMON.CONTROL'
4514       double precision u(3),ud(3)
4515       estr=0.0d0
4516       estr1=0.0d0
4517 c      write (iout,*) "distchainmax",distchainmax
4518       do i=nnt+1,nct
4519         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4520 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4521 C          do j=1,3
4522 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4523 C     &      *dc(j,i-1)/vbld(i)
4524 C          enddo
4525 C          if (energy_dec) write(iout,*)
4526 C     &       "estr1",i,vbld(i),distchainmax,
4527 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4528 C        else
4529          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4530         diff = vbld(i)-vbldpDUM
4531 C         write(iout,*) i,diff
4532          else
4533           diff = vbld(i)-vbldp0
4534 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4535          endif
4536           estr=estr+diff*diff
4537           do j=1,3
4538             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4539           enddo
4540 C        endif
4541 C        write (iout,'(a7,i5,4f7.3)')
4542 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4543       enddo
4544       estr=0.5d0*AKP*estr+estr1
4545 c
4546 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4547 c
4548       do i=nnt,nct
4549         iti=iabs(itype(i))
4550         if (iti.ne.10 .and. iti.ne.ntyp1) then
4551           nbi=nbondterm(iti)
4552           if (nbi.eq.1) then
4553             diff=vbld(i+nres)-vbldsc0(1,iti)
4554 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4555 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4556             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4557             do j=1,3
4558               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4559             enddo
4560           else
4561             do j=1,nbi
4562               diff=vbld(i+nres)-vbldsc0(j,iti)
4563               ud(j)=aksc(j,iti)*diff
4564               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4565             enddo
4566             uprod=u(1)
4567             do j=2,nbi
4568               uprod=uprod*u(j)
4569             enddo
4570             usum=0.0d0
4571             usumsqder=0.0d0
4572             do j=1,nbi
4573               uprod1=1.0d0
4574               uprod2=1.0d0
4575               do k=1,nbi
4576                 if (k.ne.j) then
4577                   uprod1=uprod1*u(k)
4578                   uprod2=uprod2*u(k)*u(k)
4579                 endif
4580               enddo
4581               usum=usum+uprod1
4582               usumsqder=usumsqder+ud(j)*uprod2
4583             enddo
4584 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4585 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4586             estr=estr+uprod/usum
4587             do j=1,3
4588              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4589             enddo
4590           endif
4591         endif
4592       enddo
4593       return
4594       end
4595 #ifdef CRYST_THETA
4596 C--------------------------------------------------------------------------
4597       subroutine ebend(etheta,ethetacnstr)
4598 C
4599 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4600 C angles gamma and its derivatives in consecutive thetas and gammas.
4601 C
4602       implicit real*8 (a-h,o-z)
4603       include 'DIMENSIONS'
4604       include 'COMMON.LOCAL'
4605       include 'COMMON.GEO'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.DERIV'
4608       include 'COMMON.VAR'
4609       include 'COMMON.CHAIN'
4610       include 'COMMON.IOUNITS'
4611       include 'COMMON.NAMES'
4612       include 'COMMON.FFIELD'
4613       include 'COMMON.TORCNSTR'
4614       common /calcthet/ term1,term2,termm,diffak,ratak,
4615      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4616      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4617       double precision y(2),z(2)
4618       delta=0.02d0*pi
4619 c      time11=dexp(-2*time)
4620 c      time12=1.0d0
4621       etheta=0.0D0
4622 c      write (iout,*) "nres",nres
4623 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4624 c      write (iout,*) ithet_start,ithet_end
4625       do i=ithet_start,ithet_end
4626 C        if (itype(i-1).eq.ntyp1) cycle
4627         if (i.le.2) cycle
4628         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4629      &  .or.itype(i).eq.ntyp1) cycle
4630 C Zero the energy function and its derivative at 0 or pi.
4631         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4632         it=itype(i-1)
4633         ichir1=isign(1,itype(i-2))
4634         ichir2=isign(1,itype(i))
4635          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4636          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4637          if (itype(i-1).eq.10) then
4638           itype1=isign(10,itype(i-2))
4639           ichir11=isign(1,itype(i-2))
4640           ichir12=isign(1,itype(i-2))
4641           itype2=isign(10,itype(i))
4642           ichir21=isign(1,itype(i))
4643           ichir22=isign(1,itype(i))
4644          endif
4645          if (i.eq.3) then
4646           y(1)=0.0D0
4647           y(2)=0.0D0
4648           else
4649
4650         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4651 #ifdef OSF
4652           phii=phi(i)
4653 c          icrc=0
4654 c          call proc_proc(phii,icrc)
4655           if (icrc.eq.1) phii=150.0
4656 #else
4657           phii=phi(i)
4658 #endif
4659           y(1)=dcos(phii)
4660           y(2)=dsin(phii)
4661         else
4662           y(1)=0.0D0
4663           y(2)=0.0D0
4664         endif
4665         endif
4666         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4667 #ifdef OSF
4668           phii1=phi(i+1)
4669 c          icrc=0
4670 c          call proc_proc(phii1,icrc)
4671           if (icrc.eq.1) phii1=150.0
4672           phii1=pinorm(phii1)
4673           z(1)=cos(phii1)
4674 #else
4675           phii1=phi(i+1)
4676           z(1)=dcos(phii1)
4677 #endif
4678           z(2)=dsin(phii1)
4679         else
4680           z(1)=0.0D0
4681           z(2)=0.0D0
4682         endif
4683 C Calculate the "mean" value of theta from the part of the distribution
4684 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4685 C In following comments this theta will be referred to as t_c.
4686         thet_pred_mean=0.0d0
4687         do k=1,2
4688             athetk=athet(k,it,ichir1,ichir2)
4689             bthetk=bthet(k,it,ichir1,ichir2)
4690           if (it.eq.10) then
4691              athetk=athet(k,itype1,ichir11,ichir12)
4692              bthetk=bthet(k,itype2,ichir21,ichir22)
4693           endif
4694           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4695         enddo
4696 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4697         dthett=thet_pred_mean*ssd
4698         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4699 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4700 C Derivatives of the "mean" values in gamma1 and gamma2.
4701         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4702      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4703          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4704      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4705          if (it.eq.10) then
4706       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4707      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4708         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4709      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4710          endif
4711         if (theta(i).gt.pi-delta) then
4712           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4713      &         E_tc0)
4714           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4715           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4716           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4717      &        E_theta)
4718           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4719      &        E_tc)
4720         else if (theta(i).lt.delta) then
4721           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4722           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4723           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4724      &        E_theta)
4725           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4726           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4727      &        E_tc)
4728         else
4729           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4730      &        E_theta,E_tc)
4731         endif
4732         etheta=etheta+ethetai
4733 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4734 c     &      'ebend',i,ethetai,theta(i),itype(i)
4735 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4736 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4737         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4738         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4739         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4740 c 1215   continue
4741       enddo
4742       ethetacnstr=0.0d0
4743 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4744       do i=1,ntheta_constr
4745         itheta=itheta_constr(i)
4746         thetiii=theta(itheta)
4747         difi=pinorm(thetiii-theta_constr0(i))
4748         if (difi.gt.theta_drange(i)) then
4749           difi=difi-theta_drange(i)
4750           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4751           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4752      &    +for_thet_constr(i)*difi**3
4753         else if (difi.lt.-drange(i)) then
4754           difi=difi+drange(i)
4755           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4756           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4757      &    +for_thet_constr(i)*difi**3
4758         else
4759           difi=0.0
4760         endif
4761 C       if (energy_dec) then
4762 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4763 C     &    i,itheta,rad2deg*thetiii,
4764 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4765 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4766 C     &    gloc(itheta+nphi-2,icg)
4767 C        endif
4768       enddo
4769 C Ufff.... We've done all this!!!
4770       return
4771       end
4772 C---------------------------------------------------------------------------
4773       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4774      &     E_tc)
4775       implicit real*8 (a-h,o-z)
4776       include 'DIMENSIONS'
4777       include 'COMMON.LOCAL'
4778       include 'COMMON.IOUNITS'
4779       common /calcthet/ term1,term2,termm,diffak,ratak,
4780      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4781      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4782 C Calculate the contributions to both Gaussian lobes.
4783 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4784 C The "polynomial part" of the "standard deviation" of this part of
4785 C the distribution.
4786         sig=polthet(3,it)
4787         do j=2,0,-1
4788           sig=sig*thet_pred_mean+polthet(j,it)
4789         enddo
4790 C Derivative of the "interior part" of the "standard deviation of the"
4791 C gamma-dependent Gaussian lobe in t_c.
4792         sigtc=3*polthet(3,it)
4793         do j=2,1,-1
4794           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4795         enddo
4796         sigtc=sig*sigtc
4797 C Set the parameters of both Gaussian lobes of the distribution.
4798 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4799         fac=sig*sig+sigc0(it)
4800         sigcsq=fac+fac
4801         sigc=1.0D0/sigcsq
4802 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4803         sigsqtc=-4.0D0*sigcsq*sigtc
4804 c       print *,i,sig,sigtc,sigsqtc
4805 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4806         sigtc=-sigtc/(fac*fac)
4807 C Following variable is sigma(t_c)**(-2)
4808         sigcsq=sigcsq*sigcsq
4809         sig0i=sig0(it)
4810         sig0inv=1.0D0/sig0i**2
4811         delthec=thetai-thet_pred_mean
4812         delthe0=thetai-theta0i
4813         term1=-0.5D0*sigcsq*delthec*delthec
4814         term2=-0.5D0*sig0inv*delthe0*delthe0
4815 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4816 C NaNs in taking the logarithm. We extract the largest exponent which is added
4817 C to the energy (this being the log of the distribution) at the end of energy
4818 C term evaluation for this virtual-bond angle.
4819         if (term1.gt.term2) then
4820           termm=term1
4821           term2=dexp(term2-termm)
4822           term1=1.0d0
4823         else
4824           termm=term2
4825           term1=dexp(term1-termm)
4826           term2=1.0d0
4827         endif
4828 C The ratio between the gamma-independent and gamma-dependent lobes of
4829 C the distribution is a Gaussian function of thet_pred_mean too.
4830         diffak=gthet(2,it)-thet_pred_mean
4831         ratak=diffak/gthet(3,it)**2
4832         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4833 C Let's differentiate it in thet_pred_mean NOW.
4834         aktc=ak*ratak
4835 C Now put together the distribution terms to make complete distribution.
4836         termexp=term1+ak*term2
4837         termpre=sigc+ak*sig0i
4838 C Contribution of the bending energy from this theta is just the -log of
4839 C the sum of the contributions from the two lobes and the pre-exponential
4840 C factor. Simple enough, isn't it?
4841         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4842 C NOW the derivatives!!!
4843 C 6/6/97 Take into account the deformation.
4844         E_theta=(delthec*sigcsq*term1
4845      &       +ak*delthe0*sig0inv*term2)/termexp
4846         E_tc=((sigtc+aktc*sig0i)/termpre
4847      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4848      &       aktc*term2)/termexp)
4849       return
4850       end
4851 c-----------------------------------------------------------------------------
4852       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4853       implicit real*8 (a-h,o-z)
4854       include 'DIMENSIONS'
4855       include 'COMMON.LOCAL'
4856       include 'COMMON.IOUNITS'
4857       common /calcthet/ term1,term2,termm,diffak,ratak,
4858      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4859      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4860       delthec=thetai-thet_pred_mean
4861       delthe0=thetai-theta0i
4862 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4863       t3 = thetai-thet_pred_mean
4864       t6 = t3**2
4865       t9 = term1
4866       t12 = t3*sigcsq
4867       t14 = t12+t6*sigsqtc
4868       t16 = 1.0d0
4869       t21 = thetai-theta0i
4870       t23 = t21**2
4871       t26 = term2
4872       t27 = t21*t26
4873       t32 = termexp
4874       t40 = t32**2
4875       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4876      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4877      & *(-t12*t9-ak*sig0inv*t27)
4878       return
4879       end
4880 #else
4881 C--------------------------------------------------------------------------
4882       subroutine ebend(etheta)
4883 C
4884 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4885 C angles gamma and its derivatives in consecutive thetas and gammas.
4886 C ab initio-derived potentials from
4887 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4888 C
4889       implicit real*8 (a-h,o-z)
4890       include 'DIMENSIONS'
4891       include 'COMMON.LOCAL'
4892       include 'COMMON.GEO'
4893       include 'COMMON.INTERACT'
4894       include 'COMMON.DERIV'
4895       include 'COMMON.VAR'
4896       include 'COMMON.CHAIN'
4897       include 'COMMON.IOUNITS'
4898       include 'COMMON.NAMES'
4899       include 'COMMON.FFIELD'
4900       include 'COMMON.CONTROL'
4901       include 'COMMON.TORCNSTR'
4902       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4903      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4904      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4905      & sinph1ph2(maxdouble,maxdouble)
4906       logical lprn /.false./, lprn1 /.false./
4907       etheta=0.0D0
4908 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4909       do i=ithet_start,ithet_end
4910 C         if (i.eq.2) cycle
4911 C        if (itype(i-1).eq.ntyp1) cycle
4912         if (i.le.2) cycle
4913         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4914      &  .or.itype(i).eq.ntyp1) cycle
4915         if (iabs(itype(i+1)).eq.20) iblock=2
4916         if (iabs(itype(i+1)).ne.20) iblock=1
4917         dethetai=0.0d0
4918         dephii=0.0d0
4919         dephii1=0.0d0
4920         theti2=0.5d0*theta(i)
4921         ityp2=ithetyp((itype(i-1)))
4922         do k=1,nntheterm
4923           coskt(k)=dcos(k*theti2)
4924           sinkt(k)=dsin(k*theti2)
4925         enddo
4926         if (i.eq.3) then
4927           phii=0.0d0
4928           ityp1=nthetyp+1
4929           do k=1,nsingle
4930             cosph1(k)=0.0d0
4931             sinph1(k)=0.0d0
4932           enddo
4933         else
4934         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4935 #ifdef OSF
4936           phii=phi(i)
4937           if (phii.ne.phii) phii=150.0
4938 #else
4939           phii=phi(i)
4940 #endif
4941           ityp1=ithetyp((itype(i-2)))
4942           do k=1,nsingle
4943             cosph1(k)=dcos(k*phii)
4944             sinph1(k)=dsin(k*phii)
4945           enddo
4946         else
4947           phii=0.0d0
4948 c          ityp1=nthetyp+1
4949           do k=1,nsingle
4950             ityp1=ithetyp((itype(i-2)))
4951             cosph1(k)=0.0d0
4952             sinph1(k)=0.0d0
4953           enddo
4954         endif
4955         endif
4956         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4957 #ifdef OSF
4958           phii1=phi(i+1)
4959           if (phii1.ne.phii1) phii1=150.0
4960           phii1=pinorm(phii1)
4961 #else
4962           phii1=phi(i+1)
4963 #endif
4964           ityp3=ithetyp((itype(i)))
4965           do k=1,nsingle
4966             cosph2(k)=dcos(k*phii1)
4967             sinph2(k)=dsin(k*phii1)
4968           enddo
4969         else
4970           phii1=0.0d0
4971 c          ityp3=nthetyp+1
4972           ityp3=ithetyp((itype(i)))
4973           do k=1,nsingle
4974             cosph2(k)=0.0d0
4975             sinph2(k)=0.0d0
4976           enddo
4977         endif
4978 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4979 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4980 c        call flush(iout)
4981         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4982         do k=1,ndouble
4983           do l=1,k-1
4984             ccl=cosph1(l)*cosph2(k-l)
4985             ssl=sinph1(l)*sinph2(k-l)
4986             scl=sinph1(l)*cosph2(k-l)
4987             csl=cosph1(l)*sinph2(k-l)
4988             cosph1ph2(l,k)=ccl-ssl
4989             cosph1ph2(k,l)=ccl+ssl
4990             sinph1ph2(l,k)=scl+csl
4991             sinph1ph2(k,l)=scl-csl
4992           enddo
4993         enddo
4994         if (lprn) then
4995         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4996      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4997         write (iout,*) "coskt and sinkt"
4998         do k=1,nntheterm
4999           write (iout,*) k,coskt(k),sinkt(k)
5000         enddo
5001         endif
5002         do k=1,ntheterm
5003           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5004           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5005      &      *coskt(k)
5006           if (lprn)
5007      &    write (iout,*) "k",k,"
5008      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5009      &     " ethetai",ethetai
5010         enddo
5011         if (lprn) then
5012         write (iout,*) "cosph and sinph"
5013         do k=1,nsingle
5014           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5015         enddo
5016         write (iout,*) "cosph1ph2 and sinph2ph2"
5017         do k=2,ndouble
5018           do l=1,k-1
5019             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5020      &         sinph1ph2(l,k),sinph1ph2(k,l)
5021           enddo
5022         enddo
5023         write(iout,*) "ethetai",ethetai
5024         endif
5025         do m=1,ntheterm2
5026           do k=1,nsingle
5027             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5028      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5029      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5030      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5031             ethetai=ethetai+sinkt(m)*aux
5032             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5033             dephii=dephii+k*sinkt(m)*(
5034      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5035      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5036             dephii1=dephii1+k*sinkt(m)*(
5037      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5038      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5039             if (lprn)
5040      &      write (iout,*) "m",m," k",k," bbthet",
5041      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5042      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5043      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5044      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5045           enddo
5046         enddo
5047         if (lprn)
5048      &  write(iout,*) "ethetai",ethetai
5049         do m=1,ntheterm3
5050           do k=2,ndouble
5051             do l=1,k-1
5052               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5053      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5054      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5055      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5056               ethetai=ethetai+sinkt(m)*aux
5057               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5058               dephii=dephii+l*sinkt(m)*(
5059      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5060      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5061      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5062      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5063               dephii1=dephii1+(k-l)*sinkt(m)*(
5064      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5065      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5066      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5067      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5068               if (lprn) then
5069               write (iout,*) "m",m," k",k," l",l," ffthet",
5070      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5071      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5072      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5073      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5074      &            " ethetai",ethetai
5075               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5076      &            cosph1ph2(k,l)*sinkt(m),
5077      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5078               endif
5079             enddo
5080           enddo
5081         enddo
5082 10      continue
5083         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5084      &   i,theta(i)*rad2deg,phii*rad2deg,
5085      &   phii1*rad2deg,ethetai
5086         etheta=etheta+ethetai
5087         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5088         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5089 c        gloc(nphi+i-2,icg)=wang*dethetai
5090         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5091       enddo
5092       return
5093       end
5094 #endif
5095 #ifdef CRYST_SC
5096 c-----------------------------------------------------------------------------
5097       subroutine esc(escloc)
5098 C Calculate the local energy of a side chain and its derivatives in the
5099 C corresponding virtual-bond valence angles THETA and the spherical angles
5100 C ALPHA and OMEGA.
5101       implicit real*8 (a-h,o-z)
5102       include 'DIMENSIONS'
5103       include 'COMMON.GEO'
5104       include 'COMMON.LOCAL'
5105       include 'COMMON.VAR'
5106       include 'COMMON.INTERACT'
5107       include 'COMMON.DERIV'
5108       include 'COMMON.CHAIN'
5109       include 'COMMON.IOUNITS'
5110       include 'COMMON.NAMES'
5111       include 'COMMON.FFIELD'
5112       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5113      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5114       common /sccalc/ time11,time12,time112,theti,it,nlobit
5115       delta=0.02d0*pi
5116       escloc=0.0D0
5117 C      write (iout,*) 'ESC'
5118       do i=loc_start,loc_end
5119         it=itype(i)
5120         if (it.eq.ntyp1) cycle
5121         if (it.eq.10) goto 1
5122         nlobit=nlob(iabs(it))
5123 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5124 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5125         theti=theta(i+1)-pipol
5126         x(1)=dtan(theti)
5127         x(2)=alph(i)
5128         x(3)=omeg(i)
5129 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5130
5131         if (x(2).gt.pi-delta) then
5132           xtemp(1)=x(1)
5133           xtemp(2)=pi-delta
5134           xtemp(3)=x(3)
5135           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5136           xtemp(2)=pi
5137           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5138           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5139      &        escloci,dersc(2))
5140           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5141      &        ddersc0(1),dersc(1))
5142           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5143      &        ddersc0(3),dersc(3))
5144           xtemp(2)=pi-delta
5145           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5146           xtemp(2)=pi
5147           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5148           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5149      &            dersc0(2),esclocbi,dersc02)
5150           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5151      &            dersc12,dersc01)
5152           call splinthet(x(2),0.5d0*delta,ss,ssd)
5153           dersc0(1)=dersc01
5154           dersc0(2)=dersc02
5155           dersc0(3)=0.0d0
5156           do k=1,3
5157             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5158           enddo
5159           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5160           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5161      &             esclocbi,ss,ssd
5162           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5163 c         escloci=esclocbi
5164 c         write (iout,*) escloci
5165         else if (x(2).lt.delta) then
5166           xtemp(1)=x(1)
5167           xtemp(2)=delta
5168           xtemp(3)=x(3)
5169           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5170           xtemp(2)=0.0d0
5171           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5172           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5173      &        escloci,dersc(2))
5174           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5175      &        ddersc0(1),dersc(1))
5176           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5177      &        ddersc0(3),dersc(3))
5178           xtemp(2)=delta
5179           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5180           xtemp(2)=0.0d0
5181           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5182           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5183      &            dersc0(2),esclocbi,dersc02)
5184           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5185      &            dersc12,dersc01)
5186           dersc0(1)=dersc01
5187           dersc0(2)=dersc02
5188           dersc0(3)=0.0d0
5189           call splinthet(x(2),0.5d0*delta,ss,ssd)
5190           do k=1,3
5191             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5192           enddo
5193           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5194 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5195 c     &             esclocbi,ss,ssd
5196           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5197 C         write (iout,*) 'i=',i, escloci
5198         else
5199           call enesc(x,escloci,dersc,ddummy,.false.)
5200         endif
5201
5202         escloc=escloc+escloci
5203 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5204             write (iout,'(a6,i5,0pf7.3)')
5205      &     'escloc',i,escloci
5206
5207         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5208      &   wscloc*dersc(1)
5209         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5210         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5211     1   continue
5212       enddo
5213       return
5214       end
5215 C---------------------------------------------------------------------------
5216       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5217       implicit real*8 (a-h,o-z)
5218       include 'DIMENSIONS'
5219       include 'COMMON.GEO'
5220       include 'COMMON.LOCAL'
5221       include 'COMMON.IOUNITS'
5222       common /sccalc/ time11,time12,time112,theti,it,nlobit
5223       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5224       double precision contr(maxlob,-1:1)
5225       logical mixed
5226 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5227         escloc_i=0.0D0
5228         do j=1,3
5229           dersc(j)=0.0D0
5230           if (mixed) ddersc(j)=0.0d0
5231         enddo
5232         x3=x(3)
5233
5234 C Because of periodicity of the dependence of the SC energy in omega we have
5235 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5236 C To avoid underflows, first compute & store the exponents.
5237
5238         do iii=-1,1
5239
5240           x(3)=x3+iii*dwapi
5241
5242           do j=1,nlobit
5243             do k=1,3
5244               z(k)=x(k)-censc(k,j,it)
5245             enddo
5246             do k=1,3
5247               Axk=0.0D0
5248               do l=1,3
5249                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5250               enddo
5251               Ax(k,j,iii)=Axk
5252             enddo
5253             expfac=0.0D0
5254             do k=1,3
5255               expfac=expfac+Ax(k,j,iii)*z(k)
5256             enddo
5257             contr(j,iii)=expfac
5258           enddo ! j
5259
5260         enddo ! iii
5261
5262         x(3)=x3
5263 C As in the case of ebend, we want to avoid underflows in exponentiation and
5264 C subsequent NaNs and INFs in energy calculation.
5265 C Find the largest exponent
5266         emin=contr(1,-1)
5267         do iii=-1,1
5268           do j=1,nlobit
5269             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5270           enddo
5271         enddo
5272         emin=0.5D0*emin
5273 cd      print *,'it=',it,' emin=',emin
5274
5275 C Compute the contribution to SC energy and derivatives
5276         do iii=-1,1
5277
5278           do j=1,nlobit
5279             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5280 cd          print *,'j=',j,' expfac=',expfac
5281             escloc_i=escloc_i+expfac
5282             do k=1,3
5283               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5284             enddo
5285             if (mixed) then
5286               do k=1,3,2
5287                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5288      &            +gaussc(k,2,j,it))*expfac
5289               enddo
5290             endif
5291           enddo
5292
5293         enddo ! iii
5294
5295         dersc(1)=dersc(1)/cos(theti)**2
5296         ddersc(1)=ddersc(1)/cos(theti)**2
5297         ddersc(3)=ddersc(3)
5298
5299         escloci=-(dlog(escloc_i)-emin)
5300         do j=1,3
5301           dersc(j)=dersc(j)/escloc_i
5302         enddo
5303         if (mixed) then
5304           do j=1,3,2
5305             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5306           enddo
5307         endif
5308       return
5309       end
5310 C------------------------------------------------------------------------------
5311       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5312       implicit real*8 (a-h,o-z)
5313       include 'DIMENSIONS'
5314       include 'COMMON.GEO'
5315       include 'COMMON.LOCAL'
5316       include 'COMMON.IOUNITS'
5317       common /sccalc/ time11,time12,time112,theti,it,nlobit
5318       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5319       double precision contr(maxlob)
5320       logical mixed
5321
5322       escloc_i=0.0D0
5323
5324       do j=1,3
5325         dersc(j)=0.0D0
5326       enddo
5327
5328       do j=1,nlobit
5329         do k=1,2
5330           z(k)=x(k)-censc(k,j,it)
5331         enddo
5332         z(3)=dwapi
5333         do k=1,3
5334           Axk=0.0D0
5335           do l=1,3
5336             Axk=Axk+gaussc(l,k,j,it)*z(l)
5337           enddo
5338           Ax(k,j)=Axk
5339         enddo
5340         expfac=0.0D0
5341         do k=1,3
5342           expfac=expfac+Ax(k,j)*z(k)
5343         enddo
5344         contr(j)=expfac
5345       enddo ! j
5346
5347 C As in the case of ebend, we want to avoid underflows in exponentiation and
5348 C subsequent NaNs and INFs in energy calculation.
5349 C Find the largest exponent
5350       emin=contr(1)
5351       do j=1,nlobit
5352         if (emin.gt.contr(j)) emin=contr(j)
5353       enddo
5354       emin=0.5D0*emin
5355
5356 C Compute the contribution to SC energy and derivatives
5357
5358       dersc12=0.0d0
5359       do j=1,nlobit
5360         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5361         escloc_i=escloc_i+expfac
5362         do k=1,2
5363           dersc(k)=dersc(k)+Ax(k,j)*expfac
5364         enddo
5365         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5366      &            +gaussc(1,2,j,it))*expfac
5367         dersc(3)=0.0d0
5368       enddo
5369
5370       dersc(1)=dersc(1)/cos(theti)**2
5371       dersc12=dersc12/cos(theti)**2
5372       escloci=-(dlog(escloc_i)-emin)
5373       do j=1,2
5374         dersc(j)=dersc(j)/escloc_i
5375       enddo
5376       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5377       return
5378       end
5379 #else
5380 c----------------------------------------------------------------------------------
5381       subroutine esc(escloc)
5382 C Calculate the local energy of a side chain and its derivatives in the
5383 C corresponding virtual-bond valence angles THETA and the spherical angles
5384 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5385 C added by Urszula Kozlowska. 07/11/2007
5386 C
5387       implicit real*8 (a-h,o-z)
5388       include 'DIMENSIONS'
5389       include 'COMMON.GEO'
5390       include 'COMMON.LOCAL'
5391       include 'COMMON.VAR'
5392       include 'COMMON.SCROT'
5393       include 'COMMON.INTERACT'
5394       include 'COMMON.DERIV'
5395       include 'COMMON.CHAIN'
5396       include 'COMMON.IOUNITS'
5397       include 'COMMON.NAMES'
5398       include 'COMMON.FFIELD'
5399       include 'COMMON.CONTROL'
5400       include 'COMMON.VECTORS'
5401       double precision x_prime(3),y_prime(3),z_prime(3)
5402      &    , sumene,dsc_i,dp2_i,x(65),
5403      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5404      &    de_dxx,de_dyy,de_dzz,de_dt
5405       double precision s1_t,s1_6_t,s2_t,s2_6_t
5406       double precision
5407      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5408      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5409      & dt_dCi(3),dt_dCi1(3)
5410       common /sccalc/ time11,time12,time112,theti,it,nlobit
5411       delta=0.02d0*pi
5412       escloc=0.0D0
5413       do i=loc_start,loc_end
5414         if (itype(i).eq.ntyp1) cycle
5415         costtab(i+1) =dcos(theta(i+1))
5416         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5417         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5418         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5419         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5420         cosfac=dsqrt(cosfac2)
5421         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5422         sinfac=dsqrt(sinfac2)
5423         it=iabs(itype(i))
5424         if (it.eq.10) goto 1
5425 c
5426 C  Compute the axes of tghe local cartesian coordinates system; store in
5427 c   x_prime, y_prime and z_prime
5428 c
5429         do j=1,3
5430           x_prime(j) = 0.00
5431           y_prime(j) = 0.00
5432           z_prime(j) = 0.00
5433         enddo
5434 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5435 C     &   dc_norm(3,i+nres)
5436         do j = 1,3
5437           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5438           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5439         enddo
5440         do j = 1,3
5441           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5442         enddo
5443 c       write (2,*) "i",i
5444 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5445 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5446 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5447 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5448 c      & " xy",scalar(x_prime(1),y_prime(1)),
5449 c      & " xz",scalar(x_prime(1),z_prime(1)),
5450 c      & " yy",scalar(y_prime(1),y_prime(1)),
5451 c      & " yz",scalar(y_prime(1),z_prime(1)),
5452 c      & " zz",scalar(z_prime(1),z_prime(1))
5453 c
5454 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5455 C to local coordinate system. Store in xx, yy, zz.
5456 c
5457         xx=0.0d0
5458         yy=0.0d0
5459         zz=0.0d0
5460         do j = 1,3
5461           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5462           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5463           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5464         enddo
5465
5466         xxtab(i)=xx
5467         yytab(i)=yy
5468         zztab(i)=zz
5469 C
5470 C Compute the energy of the ith side cbain
5471 C
5472 c        write (2,*) "xx",xx," yy",yy," zz",zz
5473         it=iabs(itype(i))
5474         do j = 1,65
5475           x(j) = sc_parmin(j,it)
5476         enddo
5477 #ifdef CHECK_COORD
5478 Cc diagnostics - remove later
5479         xx1 = dcos(alph(2))
5480         yy1 = dsin(alph(2))*dcos(omeg(2))
5481         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5482         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5483      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5484      &    xx1,yy1,zz1
5485 C,"  --- ", xx_w,yy_w,zz_w
5486 c end diagnostics
5487 #endif
5488         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5489      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5490      &   + x(10)*yy*zz
5491         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5492      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5493      & + x(20)*yy*zz
5494         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5495      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5496      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5497      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5498      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5499      &  +x(40)*xx*yy*zz
5500         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5501      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5502      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5503      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5504      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5505      &  +x(60)*xx*yy*zz
5506         dsc_i   = 0.743d0+x(61)
5507         dp2_i   = 1.9d0+x(62)
5508         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5509      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5510         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5511      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5512         s1=(1+x(63))/(0.1d0 + dscp1)
5513         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5514         s2=(1+x(65))/(0.1d0 + dscp2)
5515         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5516         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5517      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5518 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5519 c     &   sumene4,
5520 c     &   dscp1,dscp2,sumene
5521 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5522         escloc = escloc + sumene
5523 c        write (2,*) "escloc",escloc
5524 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5525 c     &  zz,xx,yy
5526         if (.not. calc_grad) goto 1
5527 #ifdef DEBUG
5528 C
5529 C This section to check the numerical derivatives of the energy of ith side
5530 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5531 C #define DEBUG in the code to turn it on.
5532 C
5533         write (2,*) "sumene               =",sumene
5534         aincr=1.0d-7
5535         xxsave=xx
5536         xx=xx+aincr
5537         write (2,*) xx,yy,zz
5538         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5539         de_dxx_num=(sumenep-sumene)/aincr
5540         xx=xxsave
5541         write (2,*) "xx+ sumene from enesc=",sumenep
5542         yysave=yy
5543         yy=yy+aincr
5544         write (2,*) xx,yy,zz
5545         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5546         de_dyy_num=(sumenep-sumene)/aincr
5547         yy=yysave
5548         write (2,*) "yy+ sumene from enesc=",sumenep
5549         zzsave=zz
5550         zz=zz+aincr
5551         write (2,*) xx,yy,zz
5552         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5553         de_dzz_num=(sumenep-sumene)/aincr
5554         zz=zzsave
5555         write (2,*) "zz+ sumene from enesc=",sumenep
5556         costsave=cost2tab(i+1)
5557         sintsave=sint2tab(i+1)
5558         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5559         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5560         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5561         de_dt_num=(sumenep-sumene)/aincr
5562         write (2,*) " t+ sumene from enesc=",sumenep
5563         cost2tab(i+1)=costsave
5564         sint2tab(i+1)=sintsave
5565 C End of diagnostics section.
5566 #endif
5567 C
5568 C Compute the gradient of esc
5569 C
5570         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5571         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5572         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5573         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5574         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5575         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5576         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5577         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5578         pom1=(sumene3*sint2tab(i+1)+sumene1)
5579      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5580         pom2=(sumene4*cost2tab(i+1)+sumene2)
5581      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5582         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5583         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5584      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5585      &  +x(40)*yy*zz
5586         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5587         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5588      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5589      &  +x(60)*yy*zz
5590         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5591      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5592      &        +(pom1+pom2)*pom_dx
5593 #ifdef DEBUG
5594         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5595 #endif
5596 C
5597         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5598         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5599      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5600      &  +x(40)*xx*zz
5601         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5602         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5603      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5604      &  +x(59)*zz**2 +x(60)*xx*zz
5605         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5606      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5607      &        +(pom1-pom2)*pom_dy
5608 #ifdef DEBUG
5609         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5610 #endif
5611 C
5612         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5613      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5614      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5615      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5616      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5617      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5618      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5619      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5620 #ifdef DEBUG
5621         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5622 #endif
5623 C
5624         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5625      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5626      &  +pom1*pom_dt1+pom2*pom_dt2
5627 #ifdef DEBUG
5628         write(2,*), "de_dt = ", de_dt,de_dt_num
5629 #endif
5630 c
5631 C
5632        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5633        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5634        cosfac2xx=cosfac2*xx
5635        sinfac2yy=sinfac2*yy
5636        do k = 1,3
5637          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5638      &      vbld_inv(i+1)
5639          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5640      &      vbld_inv(i)
5641          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5642          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5643 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5644 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5645 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5646 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5647          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5648          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5649          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5650          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5651          dZZ_Ci1(k)=0.0d0
5652          dZZ_Ci(k)=0.0d0
5653          do j=1,3
5654            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5655      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5656            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5657      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5658          enddo
5659
5660          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5661          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5662          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5663 c
5664          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5665          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5666        enddo
5667
5668        do k=1,3
5669          dXX_Ctab(k,i)=dXX_Ci(k)
5670          dXX_C1tab(k,i)=dXX_Ci1(k)
5671          dYY_Ctab(k,i)=dYY_Ci(k)
5672          dYY_C1tab(k,i)=dYY_Ci1(k)
5673          dZZ_Ctab(k,i)=dZZ_Ci(k)
5674          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5675          dXX_XYZtab(k,i)=dXX_XYZ(k)
5676          dYY_XYZtab(k,i)=dYY_XYZ(k)
5677          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5678        enddo
5679
5680        do k = 1,3
5681 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5682 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5683 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5684 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5685 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5686 c     &    dt_dci(k)
5687 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5688 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5689          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5690      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5691          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5692      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5693          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5694      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5695        enddo
5696 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5697 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5698
5699 C to check gradient call subroutine check_grad
5700
5701     1 continue
5702       enddo
5703       return
5704       end
5705 #endif
5706 c------------------------------------------------------------------------------
5707       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5708 C
5709 C This procedure calculates two-body contact function g(rij) and its derivative:
5710 C
5711 C           eps0ij                                     !       x < -1
5712 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5713 C            0                                         !       x > 1
5714 C
5715 C where x=(rij-r0ij)/delta
5716 C
5717 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5718 C
5719       implicit none
5720       double precision rij,r0ij,eps0ij,fcont,fprimcont
5721       double precision x,x2,x4,delta
5722 c     delta=0.02D0*r0ij
5723 c      delta=0.2D0*r0ij
5724       x=(rij-r0ij)/delta
5725       if (x.lt.-1.0D0) then
5726         fcont=eps0ij
5727         fprimcont=0.0D0
5728       else if (x.le.1.0D0) then
5729         x2=x*x
5730         x4=x2*x2
5731         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5732         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5733       else
5734         fcont=0.0D0
5735         fprimcont=0.0D0
5736       endif
5737       return
5738       end
5739 c------------------------------------------------------------------------------
5740       subroutine splinthet(theti,delta,ss,ssder)
5741       implicit real*8 (a-h,o-z)
5742       include 'DIMENSIONS'
5743       include 'COMMON.VAR'
5744       include 'COMMON.GEO'
5745       thetup=pi-delta
5746       thetlow=delta
5747       if (theti.gt.pipol) then
5748         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5749       else
5750         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5751         ssder=-ssder
5752       endif
5753       return
5754       end
5755 c------------------------------------------------------------------------------
5756       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5757       implicit none
5758       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5759       double precision ksi,ksi2,ksi3,a1,a2,a3
5760       a1=fprim0*delta/(f1-f0)
5761       a2=3.0d0-2.0d0*a1
5762       a3=a1-2.0d0
5763       ksi=(x-x0)/delta
5764       ksi2=ksi*ksi
5765       ksi3=ksi2*ksi
5766       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5767       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5768       return
5769       end
5770 c------------------------------------------------------------------------------
5771       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5772       implicit none
5773       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5774       double precision ksi,ksi2,ksi3,a1,a2,a3
5775       ksi=(x-x0)/delta
5776       ksi2=ksi*ksi
5777       ksi3=ksi2*ksi
5778       a1=fprim0x*delta
5779       a2=3*(f1x-f0x)-2*fprim0x*delta
5780       a3=fprim0x*delta-2*(f1x-f0x)
5781       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5782       return
5783       end
5784 C-----------------------------------------------------------------------------
5785 #ifdef CRYST_TOR
5786 C-----------------------------------------------------------------------------
5787       subroutine etor(etors,fact)
5788       implicit real*8 (a-h,o-z)
5789       include 'DIMENSIONS'
5790       include 'COMMON.VAR'
5791       include 'COMMON.GEO'
5792       include 'COMMON.LOCAL'
5793       include 'COMMON.TORSION'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.DERIV'
5796       include 'COMMON.CHAIN'
5797       include 'COMMON.NAMES'
5798       include 'COMMON.IOUNITS'
5799       include 'COMMON.FFIELD'
5800       include 'COMMON.TORCNSTR'
5801       logical lprn
5802 C Set lprn=.true. for debugging
5803       lprn=.false.
5804 c      lprn=.true.
5805       etors=0.0D0
5806       do i=iphi_start,iphi_end
5807         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5808      &      .or. itype(i).eq.ntyp1) cycle
5809         itori=itortyp(itype(i-2))
5810         itori1=itortyp(itype(i-1))
5811         phii=phi(i)
5812         gloci=0.0D0
5813 C Proline-Proline pair is a special case...
5814         if (itori.eq.3 .and. itori1.eq.3) then
5815           if (phii.gt.-dwapi3) then
5816             cosphi=dcos(3*phii)
5817             fac=1.0D0/(1.0D0-cosphi)
5818             etorsi=v1(1,3,3)*fac
5819             etorsi=etorsi+etorsi
5820             etors=etors+etorsi-v1(1,3,3)
5821             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5822           endif
5823           do j=1,3
5824             v1ij=v1(j+1,itori,itori1)
5825             v2ij=v2(j+1,itori,itori1)
5826             cosphi=dcos(j*phii)
5827             sinphi=dsin(j*phii)
5828             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5829             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5830           enddo
5831         else
5832           do j=1,nterm_old
5833             v1ij=v1(j,itori,itori1)
5834             v2ij=v2(j,itori,itori1)
5835             cosphi=dcos(j*phii)
5836             sinphi=dsin(j*phii)
5837             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5838             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5839           enddo
5840         endif
5841         if (lprn)
5842      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5843      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5844      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5845         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5846 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5847       enddo
5848       return
5849       end
5850 c------------------------------------------------------------------------------
5851 #else
5852       subroutine etor(etors,fact)
5853       implicit real*8 (a-h,o-z)
5854       include 'DIMENSIONS'
5855       include 'COMMON.VAR'
5856       include 'COMMON.GEO'
5857       include 'COMMON.LOCAL'
5858       include 'COMMON.TORSION'
5859       include 'COMMON.INTERACT'
5860       include 'COMMON.DERIV'
5861       include 'COMMON.CHAIN'
5862       include 'COMMON.NAMES'
5863       include 'COMMON.IOUNITS'
5864       include 'COMMON.FFIELD'
5865       include 'COMMON.TORCNSTR'
5866       logical lprn
5867 C Set lprn=.true. for debugging
5868       lprn=.false.
5869 c      lprn=.true.
5870       etors=0.0D0
5871       do i=iphi_start,iphi_end
5872         if (i.le.2) cycle
5873         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5874      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5875 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5876 C     &       .or. itype(i).eq.ntyp1) cycle
5877         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5878          if (iabs(itype(i)).eq.20) then
5879          iblock=2
5880          else
5881          iblock=1
5882          endif
5883         itori=itortyp(itype(i-2))
5884         itori1=itortyp(itype(i-1))
5885         phii=phi(i)
5886         gloci=0.0D0
5887 C Regular cosine and sine terms
5888         do j=1,nterm(itori,itori1,iblock)
5889           v1ij=v1(j,itori,itori1,iblock)
5890           v2ij=v2(j,itori,itori1,iblock)
5891           cosphi=dcos(j*phii)
5892           sinphi=dsin(j*phii)
5893           etors=etors+v1ij*cosphi+v2ij*sinphi
5894           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5895         enddo
5896 C Lorentz terms
5897 C                         v1
5898 C  E = SUM ----------------------------------- - v1
5899 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5900 C
5901         cosphi=dcos(0.5d0*phii)
5902         sinphi=dsin(0.5d0*phii)
5903         do j=1,nlor(itori,itori1,iblock)
5904           vl1ij=vlor1(j,itori,itori1)
5905           vl2ij=vlor2(j,itori,itori1)
5906           vl3ij=vlor3(j,itori,itori1)
5907           pom=vl2ij*cosphi+vl3ij*sinphi
5908           pom1=1.0d0/(pom*pom+1.0d0)
5909           etors=etors+vl1ij*pom1
5910 c          if (energy_dec) etors_ii=etors_ii+
5911 c     &                vl1ij*pom1
5912           pom=-pom*pom1*pom1
5913           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5914         enddo
5915 C Subtract the constant term
5916         etors=etors-v0(itori,itori1,iblock)
5917         if (lprn)
5918      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5919      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5920      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5921         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5922 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5923  1215   continue
5924       enddo
5925       return
5926       end
5927 c----------------------------------------------------------------------------
5928       subroutine etor_d(etors_d,fact2)
5929 C 6/23/01 Compute double torsional energy
5930       implicit real*8 (a-h,o-z)
5931       include 'DIMENSIONS'
5932       include 'COMMON.VAR'
5933       include 'COMMON.GEO'
5934       include 'COMMON.LOCAL'
5935       include 'COMMON.TORSION'
5936       include 'COMMON.INTERACT'
5937       include 'COMMON.DERIV'
5938       include 'COMMON.CHAIN'
5939       include 'COMMON.NAMES'
5940       include 'COMMON.IOUNITS'
5941       include 'COMMON.FFIELD'
5942       include 'COMMON.TORCNSTR'
5943       logical lprn
5944 C Set lprn=.true. for debugging
5945       lprn=.false.
5946 c     lprn=.true.
5947       etors_d=0.0D0
5948       do i=iphi_start,iphi_end-1
5949         if (i.le.3) cycle
5950 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5951 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5952          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5953      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5954      &  (itype(i+1).eq.ntyp1)) cycle
5955         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5956      &     goto 1215
5957         itori=itortyp(itype(i-2))
5958         itori1=itortyp(itype(i-1))
5959         itori2=itortyp(itype(i))
5960         phii=phi(i)
5961         phii1=phi(i+1)
5962         gloci1=0.0D0
5963         gloci2=0.0D0
5964         iblock=1
5965         if (iabs(itype(i+1)).eq.20) iblock=2
5966 C Regular cosine and sine terms
5967         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5968           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5969           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5970           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5971           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5972           cosphi1=dcos(j*phii)
5973           sinphi1=dsin(j*phii)
5974           cosphi2=dcos(j*phii1)
5975           sinphi2=dsin(j*phii1)
5976           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5977      &     v2cij*cosphi2+v2sij*sinphi2
5978           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5979           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5980         enddo
5981         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5982           do l=1,k-1
5983             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5984             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5985             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5986             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5987             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5988             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5989             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5990             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5991             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5992      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5993             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5994      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5995             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5996      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5997           enddo
5998         enddo
5999         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6000         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6001  1215   continue
6002       enddo
6003       return
6004       end
6005 #endif
6006 c---------------------------------------------------------------------------
6007 C The rigorous attempt to derive energy function
6008       subroutine etor_kcc(etors,fact)
6009       implicit real*8 (a-h,o-z)
6010       include 'DIMENSIONS'
6011       include 'COMMON.VAR'
6012       include 'COMMON.GEO'
6013       include 'COMMON.LOCAL'
6014       include 'COMMON.TORSION'
6015       include 'COMMON.INTERACT'
6016       include 'COMMON.DERIV'
6017       include 'COMMON.CHAIN'
6018       include 'COMMON.NAMES'
6019       include 'COMMON.IOUNITS'
6020       include 'COMMON.FFIELD'
6021       include 'COMMON.TORCNSTR'
6022       include 'COMMON.CONTROL'
6023       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6024       logical lprn
6025 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6026 C Set lprn=.true. for debugging
6027       lprn=energy_dec
6028 c     lprn=.true.
6029 C      print *,"wchodze kcc"
6030       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6031       etors=0.0D0
6032       do i=iphi_start,iphi_end
6033 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6034 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6035 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6036 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6037         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6038      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6039         itori=itortyp(itype(i-2))
6040         itori1=itortyp(itype(i-1))
6041         phii=phi(i)
6042         glocig=0.0D0
6043         glocit1=0.0d0
6044         glocit2=0.0d0
6045 C to avoid multiple devision by 2
6046 c        theti22=0.5d0*theta(i)
6047 C theta 12 is the theta_1 /2
6048 C theta 22 is theta_2 /2
6049 c        theti12=0.5d0*theta(i-1)
6050 C and appropriate sinus function
6051         sinthet1=dsin(theta(i-1))
6052         sinthet2=dsin(theta(i))
6053         costhet1=dcos(theta(i-1))
6054         costhet2=dcos(theta(i))
6055 C to speed up lets store its mutliplication
6056         sint1t2=sinthet2*sinthet1
6057         sint1t2n=1.0d0
6058 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6059 C +d_n*sin(n*gamma)) *
6060 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6061 C we have two sum 1) Non-Chebyshev which is with n and gamma
6062         nval=nterm_kcc_Tb(itori,itori1)
6063         c1(0)=0.0d0
6064         c2(0)=0.0d0
6065         c1(1)=1.0d0
6066         c2(1)=1.0d0
6067         do j=2,nval
6068           c1(j)=c1(j-1)*costhet1
6069           c2(j)=c2(j-1)*costhet2
6070         enddo
6071         etori=0.0d0
6072         do j=1,nterm_kcc(itori,itori1)
6073           cosphi=dcos(j*phii)
6074           sinphi=dsin(j*phii)
6075           sint1t2n1=sint1t2n
6076           sint1t2n=sint1t2n*sint1t2
6077           sumvalc=0.0d0
6078           gradvalct1=0.0d0
6079           gradvalct2=0.0d0
6080           do k=1,nval
6081             do l=1,nval
6082               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6083               gradvalct1=gradvalct1+
6084      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6085               gradvalct2=gradvalct2+
6086      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6087             enddo
6088           enddo
6089           gradvalct1=-gradvalct1*sinthet1
6090           gradvalct2=-gradvalct2*sinthet2
6091           sumvals=0.0d0
6092           gradvalst1=0.0d0
6093           gradvalst2=0.0d0
6094           do k=1,nval
6095             do l=1,nval
6096               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6097               gradvalst1=gradvalst1+
6098      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6099               gradvalst2=gradvalst2+
6100      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6101             enddo
6102           enddo
6103           gradvalst1=-gradvalst1*sinthet1
6104           gradvalst2=-gradvalst2*sinthet2
6105           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6106 C glocig is the gradient local i site in gamma
6107           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6108 C now gradient over theta_1
6109           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6110      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6111           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6112      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6113         enddo ! j
6114         etors=etors+etori
6115 C derivative over gamma
6116         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6117 C derivative over theta1
6118         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6119 C now derivative over theta2
6120         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6121         if (lprn)
6122      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6123      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6124       enddo
6125       return
6126       end
6127 c---------------------------------------------------------------------------------------------
6128       subroutine etor_constr(edihcnstr)
6129       implicit real*8 (a-h,o-z)
6130       include 'DIMENSIONS'
6131       include 'COMMON.VAR'
6132       include 'COMMON.GEO'
6133       include 'COMMON.LOCAL'
6134       include 'COMMON.TORSION'
6135       include 'COMMON.INTERACT'
6136       include 'COMMON.DERIV'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.NAMES'
6139       include 'COMMON.IOUNITS'
6140       include 'COMMON.FFIELD'
6141       include 'COMMON.TORCNSTR'
6142       include 'COMMON.CONTROL'
6143 ! 6/20/98 - dihedral angle constraints
6144       edihcnstr=0.0d0
6145 c      do i=1,ndih_constr
6146 c      write (iout,*) "idihconstr_start",idihconstr_start,
6147 c     &  " idihconstr_end",idihconstr_end
6148       if (raw_psipred) then
6149         do i=idihconstr_start,idihconstr_end
6150           itori=idih_constr(i)
6151           phii=phi(itori)
6152           gaudih_i=vpsipred(1,i)
6153           gauder_i=0.0d0
6154           do j=1,2
6155             s = sdihed(j,i)
6156             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6157             dexpcos_i=dexp(-cos_i*cos_i)
6158             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6159             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6160      &            *cos_i*dexpcos_i/s**2
6161           enddo
6162           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6163           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6164           if (energy_dec)
6165      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6166      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6167      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6168      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6169      &     -wdihc*dlog(gaudih_i)
6170         enddo
6171       else
6172         do i=idihconstr_start,idihconstr_end
6173           itori=idih_constr(i)
6174           phii=phi(itori)
6175           difi=pinorm(phii-phi0(i))
6176           if (difi.gt.drange(i)) then
6177             difi=difi-drange(i)
6178             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6179             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6180           else if (difi.lt.-drange(i)) then
6181             difi=difi+drange(i)
6182             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6183             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6184           else
6185             difi=0.0
6186           endif
6187         enddo
6188       endif
6189       return
6190       end
6191 c----------------------------------------------------------------------------
6192 C The rigorous attempt to derive energy function
6193       subroutine ebend_kcc(etheta)
6194
6195       implicit real*8 (a-h,o-z)
6196       include 'DIMENSIONS'
6197       include 'COMMON.VAR'
6198       include 'COMMON.GEO'
6199       include 'COMMON.LOCAL'
6200       include 'COMMON.TORSION'
6201       include 'COMMON.INTERACT'
6202       include 'COMMON.DERIV'
6203       include 'COMMON.CHAIN'
6204       include 'COMMON.NAMES'
6205       include 'COMMON.IOUNITS'
6206       include 'COMMON.FFIELD'
6207       include 'COMMON.TORCNSTR'
6208       include 'COMMON.CONTROL'
6209       logical lprn
6210       double precision thybt1(maxang_kcc)
6211 C Set lprn=.true. for debugging
6212       lprn=energy_dec
6213 c     lprn=.true.
6214 C      print *,"wchodze kcc"
6215       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6216       etheta=0.0D0
6217       do i=ithet_start,ithet_end
6218 c        print *,i,itype(i-1),itype(i),itype(i-2)
6219         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6220      &  .or.itype(i).eq.ntyp1) cycle
6221         iti=iabs(itortyp(itype(i-1)))
6222         sinthet=dsin(theta(i))
6223         costhet=dcos(theta(i))
6224         do j=1,nbend_kcc_Tb(iti)
6225           thybt1(j)=v1bend_chyb(j,iti)
6226         enddo
6227         sumth1thyb=v1bend_chyb(0,iti)+
6228      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6229         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6230      &    sumth1thyb
6231         ihelp=nbend_kcc_Tb(iti)-1
6232         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6233         etheta=etheta+sumth1thyb
6234 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6235         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6236       enddo
6237       return
6238       end
6239 c-------------------------------------------------------------------------------------
6240       subroutine etheta_constr(ethetacnstr)
6241
6242       implicit real*8 (a-h,o-z)
6243       include 'DIMENSIONS'
6244       include 'COMMON.VAR'
6245       include 'COMMON.GEO'
6246       include 'COMMON.LOCAL'
6247       include 'COMMON.TORSION'
6248       include 'COMMON.INTERACT'
6249       include 'COMMON.DERIV'
6250       include 'COMMON.CHAIN'
6251       include 'COMMON.NAMES'
6252       include 'COMMON.IOUNITS'
6253       include 'COMMON.FFIELD'
6254       include 'COMMON.TORCNSTR'
6255       include 'COMMON.CONTROL'
6256       ethetacnstr=0.0d0
6257 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6258       do i=ithetaconstr_start,ithetaconstr_end
6259         itheta=itheta_constr(i)
6260         thetiii=theta(itheta)
6261         difi=pinorm(thetiii-theta_constr0(i))
6262         if (difi.gt.theta_drange(i)) then
6263           difi=difi-theta_drange(i)
6264           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6265           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6266      &    +for_thet_constr(i)*difi**3
6267         else if (difi.lt.-drange(i)) then
6268           difi=difi+drange(i)
6269           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6270           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6271      &    +for_thet_constr(i)*difi**3
6272         else
6273           difi=0.0
6274         endif
6275        if (energy_dec) then
6276         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6277      &    i,itheta,rad2deg*thetiii,
6278      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6279      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6280      &    gloc(itheta+nphi-2,icg)
6281         endif
6282       enddo
6283       return
6284       end
6285 c------------------------------------------------------------------------------
6286 c------------------------------------------------------------------------------
6287       subroutine eback_sc_corr(esccor)
6288 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6289 c        conformational states; temporarily implemented as differences
6290 c        between UNRES torsional potentials (dependent on three types of
6291 c        residues) and the torsional potentials dependent on all 20 types
6292 c        of residues computed from AM1 energy surfaces of terminally-blocked
6293 c        amino-acid residues.
6294       implicit real*8 (a-h,o-z)
6295       include 'DIMENSIONS'
6296       include 'COMMON.VAR'
6297       include 'COMMON.GEO'
6298       include 'COMMON.LOCAL'
6299       include 'COMMON.TORSION'
6300       include 'COMMON.SCCOR'
6301       include 'COMMON.INTERACT'
6302       include 'COMMON.DERIV'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.NAMES'
6305       include 'COMMON.IOUNITS'
6306       include 'COMMON.FFIELD'
6307       include 'COMMON.CONTROL'
6308       logical lprn
6309 C Set lprn=.true. for debugging
6310       lprn=.false.
6311 c      lprn=.true.
6312 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6313       esccor=0.0D0
6314       do i=itau_start,itau_end
6315         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6316         esccor_ii=0.0D0
6317         isccori=isccortyp(itype(i-2))
6318         isccori1=isccortyp(itype(i-1))
6319         phii=phi(i)
6320         do intertyp=1,3 !intertyp
6321 cc Added 09 May 2012 (Adasko)
6322 cc  Intertyp means interaction type of backbone mainchain correlation:
6323 c   1 = SC...Ca...Ca...Ca
6324 c   2 = Ca...Ca...Ca...SC
6325 c   3 = SC...Ca...Ca...SCi
6326         gloci=0.0D0
6327         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6328      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6329      &      (itype(i-1).eq.ntyp1)))
6330      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6331      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6332      &     .or.(itype(i).eq.ntyp1)))
6333      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6334      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6335      &      (itype(i-3).eq.ntyp1)))) cycle
6336         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6337         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6338      & cycle
6339        do j=1,nterm_sccor(isccori,isccori1)
6340           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6341           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6342           cosphi=dcos(j*tauangle(intertyp,i))
6343           sinphi=dsin(j*tauangle(intertyp,i))
6344            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6345            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6346          enddo
6347 C      write (iout,*)"EBACK_SC_COR",esccor,i
6348 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6349 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6350 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6351         if (lprn)
6352      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6353      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6354      &  (v1sccor(j,1,itori,itori1),j=1,6)
6355      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6356 c        gsccor_loc(i-3)=gloci
6357        enddo !intertyp
6358       enddo
6359       return
6360       end
6361 #ifdef FOURBODY
6362 c------------------------------------------------------------------------------
6363       subroutine multibody(ecorr)
6364 C This subroutine calculates multi-body contributions to energy following
6365 C the idea of Skolnick et al. If side chains I and J make a contact and
6366 C at the same time side chains I+1 and J+1 make a contact, an extra
6367 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6368       implicit real*8 (a-h,o-z)
6369       include 'DIMENSIONS'
6370       include 'COMMON.IOUNITS'
6371       include 'COMMON.DERIV'
6372       include 'COMMON.INTERACT'
6373       include 'COMMON.CONTACTS'
6374       include 'COMMON.CONTMAT'
6375       include 'COMMON.CORRMAT'
6376       double precision gx(3),gx1(3)
6377       logical lprn
6378
6379 C Set lprn=.true. for debugging
6380       lprn=.false.
6381
6382       if (lprn) then
6383         write (iout,'(a)') 'Contact function values:'
6384         do i=nnt,nct-2
6385           write (iout,'(i2,20(1x,i2,f10.5))')
6386      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6387         enddo
6388       endif
6389       ecorr=0.0D0
6390       do i=nnt,nct
6391         do j=1,3
6392           gradcorr(j,i)=0.0D0
6393           gradxorr(j,i)=0.0D0
6394         enddo
6395       enddo
6396       do i=nnt,nct-2
6397
6398         DO ISHIFT = 3,4
6399
6400         i1=i+ishift
6401         num_conti=num_cont(i)
6402         num_conti1=num_cont(i1)
6403         do jj=1,num_conti
6404           j=jcont(jj,i)
6405           do kk=1,num_conti1
6406             j1=jcont(kk,i1)
6407             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6408 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6409 cd   &                   ' ishift=',ishift
6410 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6411 C The system gains extra energy.
6412               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6413             endif   ! j1==j+-ishift
6414           enddo     ! kk
6415         enddo       ! jj
6416
6417         ENDDO ! ISHIFT
6418
6419       enddo         ! i
6420       return
6421       end
6422 c------------------------------------------------------------------------------
6423       double precision function esccorr(i,j,k,l,jj,kk)
6424       implicit real*8 (a-h,o-z)
6425       include 'DIMENSIONS'
6426       include 'COMMON.IOUNITS'
6427       include 'COMMON.DERIV'
6428       include 'COMMON.INTERACT'
6429       include 'COMMON.CONTACTS'
6430       include 'COMMON.CONTMAT'
6431       include 'COMMON.CORRMAT'
6432       double precision gx(3),gx1(3)
6433       logical lprn
6434       lprn=.false.
6435       eij=facont(jj,i)
6436       ekl=facont(kk,k)
6437 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6438 C Calculate the multi-body contribution to energy.
6439 C Calculate multi-body contributions to the gradient.
6440 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6441 cd   & k,l,(gacont(m,kk,k),m=1,3)
6442       do m=1,3
6443         gx(m) =ekl*gacont(m,jj,i)
6444         gx1(m)=eij*gacont(m,kk,k)
6445         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6446         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6447         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6448         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6449       enddo
6450       do m=i,j-1
6451         do ll=1,3
6452           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6453         enddo
6454       enddo
6455       do m=k,l-1
6456         do ll=1,3
6457           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6458         enddo
6459       enddo
6460       esccorr=-eij*ekl
6461       return
6462       end
6463 c------------------------------------------------------------------------------
6464       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6465 C This subroutine calculates multi-body contributions to hydrogen-bonding
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'COMMON.IOUNITS'
6469       include 'COMMON.FFIELD'
6470       include 'COMMON.DERIV'
6471       include 'COMMON.INTERACT'
6472       include 'COMMON.CONTACTS'
6473       include 'COMMON.CONTMAT'
6474       include 'COMMON.CORRMAT'
6475       double precision gx(3),gx1(3)
6476       logical lprn,ldone
6477
6478 C Set lprn=.true. for debugging
6479       lprn=.false.
6480       if (lprn) then
6481         write (iout,'(a)') 'Contact function values:'
6482         do i=nnt,nct-2
6483           write (iout,'(2i3,50(1x,i2,f5.2))')
6484      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6485      &    j=1,num_cont_hb(i))
6486         enddo
6487       endif
6488       ecorr=0.0D0
6489 C Remove the loop below after debugging !!!
6490       do i=nnt,nct
6491         do j=1,3
6492           gradcorr(j,i)=0.0D0
6493           gradxorr(j,i)=0.0D0
6494         enddo
6495       enddo
6496 C Calculate the local-electrostatic correlation terms
6497       do i=iatel_s,iatel_e+1
6498         i1=i+1
6499         num_conti=num_cont_hb(i)
6500         num_conti1=num_cont_hb(i+1)
6501         do jj=1,num_conti
6502           j=jcont_hb(jj,i)
6503           do kk=1,num_conti1
6504             j1=jcont_hb(kk,i1)
6505 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6506 c     &         ' jj=',jj,' kk=',kk
6507             if (j1.eq.j+1 .or. j1.eq.j-1) then
6508 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6509 C The system gains extra energy.
6510               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6511               n_corr=n_corr+1
6512             else if (j1.eq.j) then
6513 C Contacts I-J and I-(J+1) occur simultaneously.
6514 C The system loses extra energy.
6515 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6516             endif
6517           enddo ! kk
6518           do kk=1,num_conti
6519             j1=jcont_hb(kk,i)
6520 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6521 c    &         ' jj=',jj,' kk=',kk
6522             if (j1.eq.j+1) then
6523 C Contacts I-J and (I+1)-J occur simultaneously.
6524 C The system loses extra energy.
6525 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6526             endif ! j1==j+1
6527           enddo ! kk
6528         enddo ! jj
6529       enddo ! i
6530       return
6531       end
6532 c------------------------------------------------------------------------------
6533       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6534      &  n_corr1)
6535 C This subroutine calculates multi-body contributions to hydrogen-bonding
6536       implicit real*8 (a-h,o-z)
6537       include 'DIMENSIONS'
6538       include 'COMMON.IOUNITS'
6539 #ifdef MPI
6540       include "mpif.h"
6541 #endif
6542       include 'COMMON.FFIELD'
6543       include 'COMMON.DERIV'
6544       include 'COMMON.LOCAL'
6545       include 'COMMON.INTERACT'
6546       include 'COMMON.CONTACTS'
6547       include 'COMMON.CONTMAT'
6548       include 'COMMON.CORRMAT'
6549       include 'COMMON.CHAIN'
6550       include 'COMMON.CONTROL'
6551       include 'COMMON.SHIELD'
6552       double precision gx(3),gx1(3)
6553       integer num_cont_hb_old(maxres)
6554       logical lprn,ldone
6555       double precision eello4,eello5,eelo6,eello_turn6
6556       external eello4,eello5,eello6,eello_turn6
6557 C Set lprn=.true. for debugging
6558       lprn=.false.
6559       eturn6=0.0d0
6560       if (lprn) then
6561         write (iout,'(a)') 'Contact function values:'
6562         do i=nnt,nct-2
6563           write (iout,'(2i3,50(1x,i2,5f6.3))')
6564      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6565      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6566         enddo
6567       endif
6568       ecorr=0.0D0
6569       ecorr5=0.0d0
6570       ecorr6=0.0d0
6571 C Remove the loop below after debugging !!!
6572       do i=nnt,nct
6573         do j=1,3
6574           gradcorr(j,i)=0.0D0
6575           gradxorr(j,i)=0.0D0
6576         enddo
6577       enddo
6578 C Calculate the dipole-dipole interaction energies
6579       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6580       do i=iatel_s,iatel_e+1
6581         num_conti=num_cont_hb(i)
6582         do jj=1,num_conti
6583           j=jcont_hb(jj,i)
6584 #ifdef MOMENT
6585           call dipole(i,j,jj)
6586 #endif
6587         enddo
6588       enddo
6589       endif
6590 C Calculate the local-electrostatic correlation terms
6591 c                write (iout,*) "gradcorr5 in eello5 before loop"
6592 c                do iii=1,nres
6593 c                  write (iout,'(i5,3f10.5)')
6594 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6595 c                enddo
6596       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6597 c        write (iout,*) "corr loop i",i
6598         i1=i+1
6599         num_conti=num_cont_hb(i)
6600         num_conti1=num_cont_hb(i+1)
6601         do jj=1,num_conti
6602           j=jcont_hb(jj,i)
6603           jp=iabs(j)
6604           do kk=1,num_conti1
6605             j1=jcont_hb(kk,i1)
6606             jp1=iabs(j1)
6607 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6608 c     &         ' jj=',jj,' kk=',kk
6609 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6610             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6611      &          .or. j.lt.0 .and. j1.gt.0) .and.
6612      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6613 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6614 C The system gains extra energy.
6615               n_corr=n_corr+1
6616               sqd1=dsqrt(d_cont(jj,i))
6617               sqd2=dsqrt(d_cont(kk,i1))
6618               sred_geom = sqd1*sqd2
6619               IF (sred_geom.lt.cutoff_corr) THEN
6620                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6621      &            ekont,fprimcont)
6622 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6623 cd     &         ' jj=',jj,' kk=',kk
6624                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6625                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6626                 do l=1,3
6627                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6628                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6629                 enddo
6630                 n_corr1=n_corr1+1
6631 cd               write (iout,*) 'sred_geom=',sred_geom,
6632 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6633 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6634 cd               write (iout,*) "g_contij",g_contij
6635 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6636 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6637                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6638                 if (wcorr4.gt.0.0d0)
6639      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6640 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6641                   if (energy_dec.and.wcorr4.gt.0.0d0)
6642      1                 write (iout,'(a6,4i5,0pf7.3)')
6643      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6644 c                write (iout,*) "gradcorr5 before eello5"
6645 c                do iii=1,nres
6646 c                  write (iout,'(i5,3f10.5)')
6647 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6648 c                enddo
6649                 if (wcorr5.gt.0.0d0)
6650      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6651 c                write (iout,*) "gradcorr5 after eello5"
6652 c                do iii=1,nres
6653 c                  write (iout,'(i5,3f10.5)')
6654 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6655 c                enddo
6656                   if (energy_dec.and.wcorr5.gt.0.0d0)
6657      1                 write (iout,'(a6,4i5,0pf7.3)')
6658      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6659 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6660 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6661                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6662      &               .or. wturn6.eq.0.0d0))then
6663 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6664                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6665                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6666      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6667 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6668 cd     &            'ecorr6=',ecorr6
6669 cd                write (iout,'(4e15.5)') sred_geom,
6670 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6671 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6672 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6673                 else if (wturn6.gt.0.0d0
6674      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6675 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6676                   eturn6=eturn6+eello_turn6(i,jj,kk)
6677                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6678      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6679 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6680                 endif
6681               ENDIF
6682 1111          continue
6683             endif
6684           enddo ! kk
6685         enddo ! jj
6686       enddo ! i
6687       do i=1,nres
6688         num_cont_hb(i)=num_cont_hb_old(i)
6689       enddo
6690 c                write (iout,*) "gradcorr5 in eello5"
6691 c                do iii=1,nres
6692 c                  write (iout,'(i5,3f10.5)')
6693 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6694 c                enddo
6695       return
6696       end
6697 c------------------------------------------------------------------------------
6698       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6699       implicit real*8 (a-h,o-z)
6700       include 'DIMENSIONS'
6701       include 'COMMON.IOUNITS'
6702       include 'COMMON.DERIV'
6703       include 'COMMON.INTERACT'
6704       include 'COMMON.CONTACTS'
6705       include 'COMMON.CONTMAT'
6706       include 'COMMON.CORRMAT'
6707       include 'COMMON.SHIELD'
6708       include 'COMMON.CONTROL'
6709       double precision gx(3),gx1(3)
6710       logical lprn
6711       lprn=.false.
6712 C      print *,"wchodze",fac_shield(i),shield_mode
6713       eij=facont_hb(jj,i)
6714       ekl=facont_hb(kk,k)
6715       ees0pij=ees0p(jj,i)
6716       ees0pkl=ees0p(kk,k)
6717       ees0mij=ees0m(jj,i)
6718       ees0mkl=ees0m(kk,k)
6719       ekont=eij*ekl
6720       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6721 C*
6722 C     & fac_shield(i)**2*fac_shield(j)**2
6723 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6724 C Following 4 lines for diagnostics.
6725 cd    ees0pkl=0.0D0
6726 cd    ees0pij=1.0D0
6727 cd    ees0mkl=0.0D0
6728 cd    ees0mij=1.0D0
6729 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6730 c     & 'Contacts ',i,j,
6731 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6732 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6733 c     & 'gradcorr_long'
6734 C Calculate the multi-body contribution to energy.
6735 C      ecorr=ecorr+ekont*ees
6736 C Calculate multi-body contributions to the gradient.
6737       coeffpees0pij=coeffp*ees0pij
6738       coeffmees0mij=coeffm*ees0mij
6739       coeffpees0pkl=coeffp*ees0pkl
6740       coeffmees0mkl=coeffm*ees0mkl
6741       do ll=1,3
6742 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6743         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6744      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6745      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6746         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6747      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6748      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6749 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6750         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6751      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6752      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6753         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6754      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6755      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6756         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6757      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6758      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6759         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6760         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6761         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6762      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6763      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6764         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6765         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6766 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6767       enddo
6768 c      write (iout,*)
6769 cgrad      do m=i+1,j-1
6770 cgrad        do ll=1,3
6771 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6772 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6773 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6774 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6775 cgrad        enddo
6776 cgrad      enddo
6777 cgrad      do m=k+1,l-1
6778 cgrad        do ll=1,3
6779 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6780 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6781 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6782 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6783 cgrad        enddo
6784 cgrad      enddo
6785 c      write (iout,*) "ehbcorr",ekont*ees
6786 C      print *,ekont,ees,i,k
6787       ehbcorr=ekont*ees
6788 C now gradient over shielding
6789 C      return
6790       if (shield_mode.gt.0) then
6791        j=ees0plist(jj,i)
6792        l=ees0plist(kk,k)
6793 C        print *,i,j,fac_shield(i),fac_shield(j),
6794 C     &fac_shield(k),fac_shield(l)
6795         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6796      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6797           do ilist=1,ishield_list(i)
6798            iresshield=shield_list(ilist,i)
6799            do m=1,3
6800            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6801 C     &      *2.0
6802            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6803      &              rlocshield
6804      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6805             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6806      &+rlocshield
6807            enddo
6808           enddo
6809           do ilist=1,ishield_list(j)
6810            iresshield=shield_list(ilist,j)
6811            do m=1,3
6812            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6813 C     &     *2.0
6814            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6815      &              rlocshield
6816      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6817            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6818      &     +rlocshield
6819            enddo
6820           enddo
6821
6822           do ilist=1,ishield_list(k)
6823            iresshield=shield_list(ilist,k)
6824            do m=1,3
6825            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6826 C     &     *2.0
6827            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6828      &              rlocshield
6829      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6830            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6831      &     +rlocshield
6832            enddo
6833           enddo
6834           do ilist=1,ishield_list(l)
6835            iresshield=shield_list(ilist,l)
6836            do m=1,3
6837            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6838 C     &     *2.0
6839            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6840      &              rlocshield
6841      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6842            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6843      &     +rlocshield
6844            enddo
6845           enddo
6846 C          print *,gshieldx(m,iresshield)
6847           do m=1,3
6848             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6849      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6850             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6851      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6852             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6853      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6854             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6855      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6856
6857             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6858      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6859             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6860      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6861             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6862      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6863             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6864      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6865
6866            enddo
6867       endif
6868       endif
6869       return
6870       end
6871 #ifdef MOMENT
6872 C---------------------------------------------------------------------------
6873       subroutine dipole(i,j,jj)
6874       implicit real*8 (a-h,o-z)
6875       include 'DIMENSIONS'
6876       include 'COMMON.IOUNITS'
6877       include 'COMMON.CHAIN'
6878       include 'COMMON.FFIELD'
6879       include 'COMMON.DERIV'
6880       include 'COMMON.INTERACT'
6881       include 'COMMON.CONTACTS'
6882       include 'COMMON.CONTMAT'
6883       include 'COMMON.CORRMAT'
6884       include 'COMMON.TORSION'
6885       include 'COMMON.VAR'
6886       include 'COMMON.GEO'
6887       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6888      &  auxmat(2,2)
6889       iti1 = itortyp(itype(i+1))
6890       if (j.lt.nres-1) then
6891         itj1 = itype2loc(itype(j+1))
6892       else
6893         itj1=nloctyp
6894       endif
6895       do iii=1,2
6896         dipi(iii,1)=Ub2(iii,i)
6897         dipderi(iii)=Ub2der(iii,i)
6898         dipi(iii,2)=b1(iii,i+1)
6899         dipj(iii,1)=Ub2(iii,j)
6900         dipderj(iii)=Ub2der(iii,j)
6901         dipj(iii,2)=b1(iii,j+1)
6902       enddo
6903       kkk=0
6904       do iii=1,2
6905         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6906         do jjj=1,2
6907           kkk=kkk+1
6908           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6909         enddo
6910       enddo
6911       do kkk=1,5
6912         do lll=1,3
6913           mmm=0
6914           do iii=1,2
6915             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6916      &        auxvec(1))
6917             do jjj=1,2
6918               mmm=mmm+1
6919               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6920             enddo
6921           enddo
6922         enddo
6923       enddo
6924       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6925       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6926       do iii=1,2
6927         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6928       enddo
6929       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6930       do iii=1,2
6931         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6932       enddo
6933       return
6934       end
6935 #endif
6936 C---------------------------------------------------------------------------
6937       subroutine calc_eello(i,j,k,l,jj,kk)
6938 C
6939 C This subroutine computes matrices and vectors needed to calculate
6940 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6941 C
6942       implicit real*8 (a-h,o-z)
6943       include 'DIMENSIONS'
6944       include 'COMMON.IOUNITS'
6945       include 'COMMON.CHAIN'
6946       include 'COMMON.DERIV'
6947       include 'COMMON.INTERACT'
6948       include 'COMMON.CONTACTS'
6949       include 'COMMON.CONTMAT'
6950       include 'COMMON.CORRMAT'
6951       include 'COMMON.TORSION'
6952       include 'COMMON.VAR'
6953       include 'COMMON.GEO'
6954       include 'COMMON.FFIELD'
6955       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6956      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6957       logical lprn
6958       common /kutas/ lprn
6959 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6960 cd     & ' jj=',jj,' kk=',kk
6961 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6962 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6963 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6964       do iii=1,2
6965         do jjj=1,2
6966           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6967           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6968         enddo
6969       enddo
6970       call transpose2(aa1(1,1),aa1t(1,1))
6971       call transpose2(aa2(1,1),aa2t(1,1))
6972       do kkk=1,5
6973         do lll=1,3
6974           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6975      &      aa1tder(1,1,lll,kkk))
6976           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6977      &      aa2tder(1,1,lll,kkk))
6978         enddo
6979       enddo
6980       if (l.eq.j+1) then
6981 C parallel orientation of the two CA-CA-CA frames.
6982         if (i.gt.1) then
6983           iti=itype2loc(itype(i))
6984         else
6985           iti=nloctyp
6986         endif
6987         itk1=itype2loc(itype(k+1))
6988         itj=itype2loc(itype(j))
6989         if (l.lt.nres-1) then
6990           itl1=itype2loc(itype(l+1))
6991         else
6992           itl1=nloctyp
6993         endif
6994 C A1 kernel(j+1) A2T
6995 cd        do iii=1,2
6996 cd          write (iout,'(3f10.5,5x,3f10.5)')
6997 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6998 cd        enddo
6999         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7000      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7001      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7002 C Following matrices are needed only for 6-th order cumulants
7003         IF (wcorr6.gt.0.0d0) THEN
7004         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7005      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7006      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7008      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7009      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7010      &   ADtEAderx(1,1,1,1,1,1))
7011         lprn=.false.
7012         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7013      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7014      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7015      &   ADtEA1derx(1,1,1,1,1,1))
7016         ENDIF
7017 C End 6-th order cumulants
7018 cd        lprn=.false.
7019 cd        if (lprn) then
7020 cd        write (2,*) 'In calc_eello6'
7021 cd        do iii=1,2
7022 cd          write (2,*) 'iii=',iii
7023 cd          do kkk=1,5
7024 cd            write (2,*) 'kkk=',kkk
7025 cd            do jjj=1,2
7026 cd              write (2,'(3(2f10.5),5x)')
7027 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7028 cd            enddo
7029 cd          enddo
7030 cd        enddo
7031 cd        endif
7032         call transpose2(EUgder(1,1,k),auxmat(1,1))
7033         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7034         call transpose2(EUg(1,1,k),auxmat(1,1))
7035         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7036         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7037         do iii=1,2
7038           do kkk=1,5
7039             do lll=1,3
7040               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7041      &          EAEAderx(1,1,lll,kkk,iii,1))
7042             enddo
7043           enddo
7044         enddo
7045 C A1T kernel(i+1) A2
7046         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7047      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7048      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7049 C Following matrices are needed only for 6-th order cumulants
7050         IF (wcorr6.gt.0.0d0) THEN
7051         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7052      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7053      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7054         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7055      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7056      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7057      &   ADtEAderx(1,1,1,1,1,2))
7058         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7059      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7060      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7061      &   ADtEA1derx(1,1,1,1,1,2))
7062         ENDIF
7063 C End 6-th order cumulants
7064         call transpose2(EUgder(1,1,l),auxmat(1,1))
7065         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7066         call transpose2(EUg(1,1,l),auxmat(1,1))
7067         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7068         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7069         do iii=1,2
7070           do kkk=1,5
7071             do lll=1,3
7072               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7073      &          EAEAderx(1,1,lll,kkk,iii,2))
7074             enddo
7075           enddo
7076         enddo
7077 C AEAb1 and AEAb2
7078 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7079 C They are needed only when the fifth- or the sixth-order cumulants are
7080 C indluded.
7081         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7082         call transpose2(AEA(1,1,1),auxmat(1,1))
7083         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7084         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7085         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7086         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7087         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7088         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7089         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7090         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7091         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7092         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7093         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7094         call transpose2(AEA(1,1,2),auxmat(1,1))
7095         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7096         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7097         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7098         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7099         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7100         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7101         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7102         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7103         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7104         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7105         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7106 C Calculate the Cartesian derivatives of the vectors.
7107         do iii=1,2
7108           do kkk=1,5
7109             do lll=1,3
7110               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7111               call matvec2(auxmat(1,1),b1(1,i),
7112      &          AEAb1derx(1,lll,kkk,iii,1,1))
7113               call matvec2(auxmat(1,1),Ub2(1,i),
7114      &          AEAb2derx(1,lll,kkk,iii,1,1))
7115               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7116      &          AEAb1derx(1,lll,kkk,iii,2,1))
7117               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7118      &          AEAb2derx(1,lll,kkk,iii,2,1))
7119               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7120               call matvec2(auxmat(1,1),b1(1,j),
7121      &          AEAb1derx(1,lll,kkk,iii,1,2))
7122               call matvec2(auxmat(1,1),Ub2(1,j),
7123      &          AEAb2derx(1,lll,kkk,iii,1,2))
7124               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7125      &          AEAb1derx(1,lll,kkk,iii,2,2))
7126               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7127      &          AEAb2derx(1,lll,kkk,iii,2,2))
7128             enddo
7129           enddo
7130         enddo
7131         ENDIF
7132 C End vectors
7133       else
7134 C Antiparallel orientation of the two CA-CA-CA frames.
7135         if (i.gt.1) then
7136           iti=itype2loc(itype(i))
7137         else
7138           iti=nloctyp
7139         endif
7140         itk1=itype2loc(itype(k+1))
7141         itl=itype2loc(itype(l))
7142         itj=itype2loc(itype(j))
7143         if (j.lt.nres-1) then
7144           itj1=itype2loc(itype(j+1))
7145         else
7146           itj1=nloctyp
7147         endif
7148 C A2 kernel(j-1)T A1T
7149         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7150      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7151      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7152 C Following matrices are needed only for 6-th order cumulants
7153         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7154      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7155         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7156      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7157      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7158         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7160      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7161      &   ADtEAderx(1,1,1,1,1,1))
7162         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7163      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7164      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7165      &   ADtEA1derx(1,1,1,1,1,1))
7166         ENDIF
7167 C End 6-th order cumulants
7168         call transpose2(EUgder(1,1,k),auxmat(1,1))
7169         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7170         call transpose2(EUg(1,1,k),auxmat(1,1))
7171         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7172         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7173         do iii=1,2
7174           do kkk=1,5
7175             do lll=1,3
7176               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7177      &          EAEAderx(1,1,lll,kkk,iii,1))
7178             enddo
7179           enddo
7180         enddo
7181 C A2T kernel(i+1)T A1
7182         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7183      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7184      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7185 C Following matrices are needed only for 6-th order cumulants
7186         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7187      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7188         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7189      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7190      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7193      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7194      &   ADtEAderx(1,1,1,1,1,2))
7195         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7196      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7197      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7198      &   ADtEA1derx(1,1,1,1,1,2))
7199         ENDIF
7200 C End 6-th order cumulants
7201         call transpose2(EUgder(1,1,j),auxmat(1,1))
7202         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7203         call transpose2(EUg(1,1,j),auxmat(1,1))
7204         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7205         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7206         do iii=1,2
7207           do kkk=1,5
7208             do lll=1,3
7209               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7210      &          EAEAderx(1,1,lll,kkk,iii,2))
7211             enddo
7212           enddo
7213         enddo
7214 C AEAb1 and AEAb2
7215 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7216 C They are needed only when the fifth- or the sixth-order cumulants are
7217 C indluded.
7218         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7219      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7220         call transpose2(AEA(1,1,1),auxmat(1,1))
7221         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7222         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7223         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7224         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7225         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7226         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7227         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7228         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7229         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7230         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7231         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7232         call transpose2(AEA(1,1,2),auxmat(1,1))
7233         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7234         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7235         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7236         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7237         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7238         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7239         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7240         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7241         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7242         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7243         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7244 C Calculate the Cartesian derivatives of the vectors.
7245         do iii=1,2
7246           do kkk=1,5
7247             do lll=1,3
7248               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7249               call matvec2(auxmat(1,1),b1(1,i),
7250      &          AEAb1derx(1,lll,kkk,iii,1,1))
7251               call matvec2(auxmat(1,1),Ub2(1,i),
7252      &          AEAb2derx(1,lll,kkk,iii,1,1))
7253               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7254      &          AEAb1derx(1,lll,kkk,iii,2,1))
7255               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7256      &          AEAb2derx(1,lll,kkk,iii,2,1))
7257               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7258               call matvec2(auxmat(1,1),b1(1,l),
7259      &          AEAb1derx(1,lll,kkk,iii,1,2))
7260               call matvec2(auxmat(1,1),Ub2(1,l),
7261      &          AEAb2derx(1,lll,kkk,iii,1,2))
7262               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7263      &          AEAb1derx(1,lll,kkk,iii,2,2))
7264               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7265      &          AEAb2derx(1,lll,kkk,iii,2,2))
7266             enddo
7267           enddo
7268         enddo
7269         ENDIF
7270 C End vectors
7271       endif
7272       return
7273       end
7274 C---------------------------------------------------------------------------
7275       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7276      &  KK,KKderg,AKA,AKAderg,AKAderx)
7277       implicit none
7278       integer nderg
7279       logical transp
7280       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7281      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7282      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7283       integer iii,kkk,lll
7284       integer jjj,mmm
7285       logical lprn
7286       common /kutas/ lprn
7287       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7288       do iii=1,nderg
7289         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7290      &    AKAderg(1,1,iii))
7291       enddo
7292 cd      if (lprn) write (2,*) 'In kernel'
7293       do kkk=1,5
7294 cd        if (lprn) write (2,*) 'kkk=',kkk
7295         do lll=1,3
7296           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7297      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7298 cd          if (lprn) then
7299 cd            write (2,*) 'lll=',lll
7300 cd            write (2,*) 'iii=1'
7301 cd            do jjj=1,2
7302 cd              write (2,'(3(2f10.5),5x)')
7303 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7304 cd            enddo
7305 cd          endif
7306           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7307      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7308 cd          if (lprn) then
7309 cd            write (2,*) 'lll=',lll
7310 cd            write (2,*) 'iii=2'
7311 cd            do jjj=1,2
7312 cd              write (2,'(3(2f10.5),5x)')
7313 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7314 cd            enddo
7315 cd          endif
7316         enddo
7317       enddo
7318       return
7319       end
7320 C---------------------------------------------------------------------------
7321       double precision function eello4(i,j,k,l,jj,kk)
7322       implicit real*8 (a-h,o-z)
7323       include 'DIMENSIONS'
7324       include 'COMMON.IOUNITS'
7325       include 'COMMON.CHAIN'
7326       include 'COMMON.DERIV'
7327       include 'COMMON.INTERACT'
7328       include 'COMMON.CONTACTS'
7329       include 'COMMON.CONTMAT'
7330       include 'COMMON.CORRMAT'
7331       include 'COMMON.TORSION'
7332       include 'COMMON.VAR'
7333       include 'COMMON.GEO'
7334       double precision pizda(2,2),ggg1(3),ggg2(3)
7335 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7336 cd        eello4=0.0d0
7337 cd        return
7338 cd      endif
7339 cd      print *,'eello4:',i,j,k,l,jj,kk
7340 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7341 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7342 cold      eij=facont_hb(jj,i)
7343 cold      ekl=facont_hb(kk,k)
7344 cold      ekont=eij*ekl
7345       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7346       if (calc_grad) then
7347 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7348       gcorr_loc(k-1)=gcorr_loc(k-1)
7349      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7350       if (l.eq.j+1) then
7351         gcorr_loc(l-1)=gcorr_loc(l-1)
7352      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7353       else
7354         gcorr_loc(j-1)=gcorr_loc(j-1)
7355      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7356       endif
7357       do iii=1,2
7358         do kkk=1,5
7359           do lll=1,3
7360             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7361      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7362 cd            derx(lll,kkk,iii)=0.0d0
7363           enddo
7364         enddo
7365       enddo
7366 cd      gcorr_loc(l-1)=0.0d0
7367 cd      gcorr_loc(j-1)=0.0d0
7368 cd      gcorr_loc(k-1)=0.0d0
7369 cd      eel4=1.0d0
7370 cd      write (iout,*)'Contacts have occurred for peptide groups',
7371 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7372 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7373       if (j.lt.nres-1) then
7374         j1=j+1
7375         j2=j-1
7376       else
7377         j1=j-1
7378         j2=j-2
7379       endif
7380       if (l.lt.nres-1) then
7381         l1=l+1
7382         l2=l-1
7383       else
7384         l1=l-1
7385         l2=l-2
7386       endif
7387       do ll=1,3
7388 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7389 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7390         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7391         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7392 cgrad        ghalf=0.5d0*ggg1(ll)
7393         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7394         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7395         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7396         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7397         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7398         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7399 cgrad        ghalf=0.5d0*ggg2(ll)
7400         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7401         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7402         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7403         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7404         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7405         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7406       enddo
7407 cgrad      do m=i+1,j-1
7408 cgrad        do ll=1,3
7409 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7410 cgrad        enddo
7411 cgrad      enddo
7412 cgrad      do m=k+1,l-1
7413 cgrad        do ll=1,3
7414 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7415 cgrad        enddo
7416 cgrad      enddo
7417 cgrad      do m=i+2,j2
7418 cgrad        do ll=1,3
7419 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7420 cgrad        enddo
7421 cgrad      enddo
7422 cgrad      do m=k+2,l2
7423 cgrad        do ll=1,3
7424 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7425 cgrad        enddo
7426 cgrad      enddo
7427 cd      do iii=1,nres-3
7428 cd        write (2,*) iii,gcorr_loc(iii)
7429 cd      enddo
7430       endif ! calc_grad
7431       eello4=ekont*eel4
7432 cd      write (2,*) 'ekont',ekont
7433 cd      write (iout,*) 'eello4',ekont*eel4
7434       return
7435       end
7436 C---------------------------------------------------------------------------
7437       double precision function eello5(i,j,k,l,jj,kk)
7438       implicit real*8 (a-h,o-z)
7439       include 'DIMENSIONS'
7440       include 'COMMON.IOUNITS'
7441       include 'COMMON.CHAIN'
7442       include 'COMMON.DERIV'
7443       include 'COMMON.INTERACT'
7444       include 'COMMON.CONTACTS'
7445       include 'COMMON.CONTMAT'
7446       include 'COMMON.CORRMAT'
7447       include 'COMMON.TORSION'
7448       include 'COMMON.VAR'
7449       include 'COMMON.GEO'
7450       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7451       double precision ggg1(3),ggg2(3)
7452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7453 C                                                                              C
7454 C                            Parallel chains                                   C
7455 C                                                                              C
7456 C          o             o                   o             o                   C
7457 C         /l\           / \             \   / \           / \   /              C
7458 C        /   \         /   \             \ /   \         /   \ /               C
7459 C       j| o |l1       | o |              o| o |         | o |o                C
7460 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7461 C      \i/   \         /   \ /             /   \         /   \                 C
7462 C       o    k1             o                                                  C
7463 C         (I)          (II)                (III)          (IV)                 C
7464 C                                                                              C
7465 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7466 C                                                                              C
7467 C                            Antiparallel chains                               C
7468 C                                                                              C
7469 C          o             o                   o             o                   C
7470 C         /j\           / \             \   / \           / \   /              C
7471 C        /   \         /   \             \ /   \         /   \ /               C
7472 C      j1| o |l        | o |              o| o |         | o |o                C
7473 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7474 C      \i/   \         /   \ /             /   \         /   \                 C
7475 C       o     k1            o                                                  C
7476 C         (I)          (II)                (III)          (IV)                 C
7477 C                                                                              C
7478 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7479 C                                                                              C
7480 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7481 C                                                                              C
7482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7483 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7484 cd        eello5=0.0d0
7485 cd        return
7486 cd      endif
7487 cd      write (iout,*)
7488 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7489 cd     &   ' and',k,l
7490       itk=itype2loc(itype(k))
7491       itl=itype2loc(itype(l))
7492       itj=itype2loc(itype(j))
7493       eello5_1=0.0d0
7494       eello5_2=0.0d0
7495       eello5_3=0.0d0
7496       eello5_4=0.0d0
7497 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7498 cd     &   eel5_3_num,eel5_4_num)
7499       do iii=1,2
7500         do kkk=1,5
7501           do lll=1,3
7502             derx(lll,kkk,iii)=0.0d0
7503           enddo
7504         enddo
7505       enddo
7506 cd      eij=facont_hb(jj,i)
7507 cd      ekl=facont_hb(kk,k)
7508 cd      ekont=eij*ekl
7509 cd      write (iout,*)'Contacts have occurred for peptide groups',
7510 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7511 cd      goto 1111
7512 C Contribution from the graph I.
7513 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7514 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7515       call transpose2(EUg(1,1,k),auxmat(1,1))
7516       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7517       vv(1)=pizda(1,1)-pizda(2,2)
7518       vv(2)=pizda(1,2)+pizda(2,1)
7519       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7520      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7521       if (calc_grad) then
7522 C Explicit gradient in virtual-dihedral angles.
7523       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7524      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7525      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7526       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7527       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7528       vv(1)=pizda(1,1)-pizda(2,2)
7529       vv(2)=pizda(1,2)+pizda(2,1)
7530       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7531      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7532      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7533       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7534       vv(1)=pizda(1,1)-pizda(2,2)
7535       vv(2)=pizda(1,2)+pizda(2,1)
7536       if (l.eq.j+1) then
7537         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7538      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7539      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7540       else
7541         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7542      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7543      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7544       endif
7545 C Cartesian gradient
7546       do iii=1,2
7547         do kkk=1,5
7548           do lll=1,3
7549             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7550      &        pizda(1,1))
7551             vv(1)=pizda(1,1)-pizda(2,2)
7552             vv(2)=pizda(1,2)+pizda(2,1)
7553             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7554      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7555      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7556           enddo
7557         enddo
7558       enddo
7559       endif ! calc_grad
7560 c      goto 1112
7561 c1111  continue
7562 C Contribution from graph II
7563       call transpose2(EE(1,1,k),auxmat(1,1))
7564       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7565       vv(1)=pizda(1,1)+pizda(2,2)
7566       vv(2)=pizda(2,1)-pizda(1,2)
7567       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7568      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7569       if (calc_grad) then
7570 C Explicit gradient in virtual-dihedral angles.
7571       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7572      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7573       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7574       vv(1)=pizda(1,1)+pizda(2,2)
7575       vv(2)=pizda(2,1)-pizda(1,2)
7576       if (l.eq.j+1) then
7577         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7578      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7579      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7580       else
7581         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7582      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7583      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7584       endif
7585 C Cartesian gradient
7586       do iii=1,2
7587         do kkk=1,5
7588           do lll=1,3
7589             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7590      &        pizda(1,1))
7591             vv(1)=pizda(1,1)+pizda(2,2)
7592             vv(2)=pizda(2,1)-pizda(1,2)
7593             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7594      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7595      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7596           enddo
7597         enddo
7598       enddo
7599       endif ! calc_grad
7600 cd      goto 1112
7601 cd1111  continue
7602       if (l.eq.j+1) then
7603 cd        goto 1110
7604 C Parallel orientation
7605 C Contribution from graph III
7606         call transpose2(EUg(1,1,l),auxmat(1,1))
7607         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7608         vv(1)=pizda(1,1)-pizda(2,2)
7609         vv(2)=pizda(1,2)+pizda(2,1)
7610         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7611      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7612         if (calc_grad) then
7613 C Explicit gradient in virtual-dihedral angles.
7614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7615      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7616      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7617         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7618         vv(1)=pizda(1,1)-pizda(2,2)
7619         vv(2)=pizda(1,2)+pizda(2,1)
7620         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7621      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7622      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7623         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7624         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7625         vv(1)=pizda(1,1)-pizda(2,2)
7626         vv(2)=pizda(1,2)+pizda(2,1)
7627         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7628      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7629      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7630 C Cartesian gradient
7631         do iii=1,2
7632           do kkk=1,5
7633             do lll=1,3
7634               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7635      &          pizda(1,1))
7636               vv(1)=pizda(1,1)-pizda(2,2)
7637               vv(2)=pizda(1,2)+pizda(2,1)
7638               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7639      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7640      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7641             enddo
7642           enddo
7643         enddo
7644 cd        goto 1112
7645 C Contribution from graph IV
7646 cd1110    continue
7647         call transpose2(EE(1,1,l),auxmat(1,1))
7648         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7649         vv(1)=pizda(1,1)+pizda(2,2)
7650         vv(2)=pizda(2,1)-pizda(1,2)
7651         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7652      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7653 C Explicit gradient in virtual-dihedral angles.
7654         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7655      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7656         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7657         vv(1)=pizda(1,1)+pizda(2,2)
7658         vv(2)=pizda(2,1)-pizda(1,2)
7659         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7660      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7661      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7662 C Cartesian gradient
7663         do iii=1,2
7664           do kkk=1,5
7665             do lll=1,3
7666               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7667      &          pizda(1,1))
7668               vv(1)=pizda(1,1)+pizda(2,2)
7669               vv(2)=pizda(2,1)-pizda(1,2)
7670               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7671      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7672      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7673             enddo
7674           enddo
7675         enddo
7676         endif ! calc_grad
7677       else
7678 C Antiparallel orientation
7679 C Contribution from graph III
7680 c        goto 1110
7681         call transpose2(EUg(1,1,j),auxmat(1,1))
7682         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7683         vv(1)=pizda(1,1)-pizda(2,2)
7684         vv(2)=pizda(1,2)+pizda(2,1)
7685         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7686      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7687         if (calc_grad) then
7688 C Explicit gradient in virtual-dihedral angles.
7689         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7690      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7692         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7693         vv(1)=pizda(1,1)-pizda(2,2)
7694         vv(2)=pizda(1,2)+pizda(2,1)
7695         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7696      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7697      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7698         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7699         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7700         vv(1)=pizda(1,1)-pizda(2,2)
7701         vv(2)=pizda(1,2)+pizda(2,1)
7702         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7703      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7704      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7705 C Cartesian gradient
7706         do iii=1,2
7707           do kkk=1,5
7708             do lll=1,3
7709               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7710      &          pizda(1,1))
7711               vv(1)=pizda(1,1)-pizda(2,2)
7712               vv(2)=pizda(1,2)+pizda(2,1)
7713               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7714      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7715      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7716             enddo
7717           enddo
7718         enddo
7719         endif ! calc_grad
7720 cd        goto 1112
7721 C Contribution from graph IV
7722 1110    continue
7723         call transpose2(EE(1,1,j),auxmat(1,1))
7724         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7725         vv(1)=pizda(1,1)+pizda(2,2)
7726         vv(2)=pizda(2,1)-pizda(1,2)
7727         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7728      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7729         if (calc_grad) then
7730 C Explicit gradient in virtual-dihedral angles.
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7733         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7734         vv(1)=pizda(1,1)+pizda(2,2)
7735         vv(2)=pizda(2,1)-pizda(1,2)
7736         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7737      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7738      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7739 C Cartesian gradient
7740         do iii=1,2
7741           do kkk=1,5
7742             do lll=1,3
7743               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7744      &          pizda(1,1))
7745               vv(1)=pizda(1,1)+pizda(2,2)
7746               vv(2)=pizda(2,1)-pizda(1,2)
7747               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7748      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7749      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7750             enddo
7751           enddo
7752         enddo
7753         endif ! calc_grad
7754       endif
7755 1112  continue
7756       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7757 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7758 cd        write (2,*) 'ijkl',i,j,k,l
7759 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7760 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7761 cd      endif
7762 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7763 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7764 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7765 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7766       if (calc_grad) then
7767       if (j.lt.nres-1) then
7768         j1=j+1
7769         j2=j-1
7770       else
7771         j1=j-1
7772         j2=j-2
7773       endif
7774       if (l.lt.nres-1) then
7775         l1=l+1
7776         l2=l-1
7777       else
7778         l1=l-1
7779         l2=l-2
7780       endif
7781 cd      eij=1.0d0
7782 cd      ekl=1.0d0
7783 cd      ekont=1.0d0
7784 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7785 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7786 C        summed up outside the subrouine as for the other subroutines
7787 C        handling long-range interactions. The old code is commented out
7788 C        with "cgrad" to keep track of changes.
7789       do ll=1,3
7790 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7791 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7792         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7793         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7794 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7795 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7796 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7797 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7798 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7799 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7800 c     &   gradcorr5ij,
7801 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7802 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7803 cgrad        ghalf=0.5d0*ggg1(ll)
7804 cd        ghalf=0.0d0
7805         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7806         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7807         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7808         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7809         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7810         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7811 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7812 cgrad        ghalf=0.5d0*ggg2(ll)
7813 cd        ghalf=0.0d0
7814         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7815         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7816         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7817         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7818         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7819         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7820       enddo
7821       endif ! calc_grad
7822 cd      goto 1112
7823 cgrad      do m=i+1,j-1
7824 cgrad        do ll=1,3
7825 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7826 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7827 cgrad        enddo
7828 cgrad      enddo
7829 cgrad      do m=k+1,l-1
7830 cgrad        do ll=1,3
7831 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7832 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7833 cgrad        enddo
7834 cgrad      enddo
7835 c1112  continue
7836 cgrad      do m=i+2,j2
7837 cgrad        do ll=1,3
7838 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7839 cgrad        enddo
7840 cgrad      enddo
7841 cgrad      do m=k+2,l2
7842 cgrad        do ll=1,3
7843 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7844 cgrad        enddo
7845 cgrad      enddo
7846 cd      do iii=1,nres-3
7847 cd        write (2,*) iii,g_corr5_loc(iii)
7848 cd      enddo
7849       eello5=ekont*eel5
7850 cd      write (2,*) 'ekont',ekont
7851 cd      write (iout,*) 'eello5',ekont*eel5
7852       return
7853       end
7854 c--------------------------------------------------------------------------
7855       double precision function eello6(i,j,k,l,jj,kk)
7856       implicit real*8 (a-h,o-z)
7857       include 'DIMENSIONS'
7858       include 'COMMON.IOUNITS'
7859       include 'COMMON.CHAIN'
7860       include 'COMMON.DERIV'
7861       include 'COMMON.INTERACT'
7862       include 'COMMON.CONTACTS'
7863       include 'COMMON.CONTMAT'
7864       include 'COMMON.CORRMAT'
7865       include 'COMMON.TORSION'
7866       include 'COMMON.VAR'
7867       include 'COMMON.GEO'
7868       include 'COMMON.FFIELD'
7869       double precision ggg1(3),ggg2(3)
7870 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7871 cd        eello6=0.0d0
7872 cd        return
7873 cd      endif
7874 cd      write (iout,*)
7875 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7876 cd     &   ' and',k,l
7877       eello6_1=0.0d0
7878       eello6_2=0.0d0
7879       eello6_3=0.0d0
7880       eello6_4=0.0d0
7881       eello6_5=0.0d0
7882       eello6_6=0.0d0
7883 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7884 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7885       do iii=1,2
7886         do kkk=1,5
7887           do lll=1,3
7888             derx(lll,kkk,iii)=0.0d0
7889           enddo
7890         enddo
7891       enddo
7892 cd      eij=facont_hb(jj,i)
7893 cd      ekl=facont_hb(kk,k)
7894 cd      ekont=eij*ekl
7895 cd      eij=1.0d0
7896 cd      ekl=1.0d0
7897 cd      ekont=1.0d0
7898       if (l.eq.j+1) then
7899         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7900         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7901         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7902         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7903         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7904         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7905       else
7906         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7907         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7908         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7909         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7910         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7911           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7912         else
7913           eello6_5=0.0d0
7914         endif
7915         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7916       endif
7917 C If turn contributions are considered, they will be handled separately.
7918       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7919 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7920 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7921 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7922 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7923 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7924 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7925 cd      goto 1112
7926       if (calc_grad) then
7927       if (j.lt.nres-1) then
7928         j1=j+1
7929         j2=j-1
7930       else
7931         j1=j-1
7932         j2=j-2
7933       endif
7934       if (l.lt.nres-1) then
7935         l1=l+1
7936         l2=l-1
7937       else
7938         l1=l-1
7939         l2=l-2
7940       endif
7941       do ll=1,3
7942 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7943 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7944 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7945 cgrad        ghalf=0.5d0*ggg1(ll)
7946 cd        ghalf=0.0d0
7947         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7948         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7949         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7950         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7951         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7952         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7953         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7954         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7955 cgrad        ghalf=0.5d0*ggg2(ll)
7956 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7957 cd        ghalf=0.0d0
7958         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7959         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7960         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7961         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7962         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7963         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7964       enddo
7965       endif ! calc_grad
7966 cd      goto 1112
7967 cgrad      do m=i+1,j-1
7968 cgrad        do ll=1,3
7969 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7970 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7971 cgrad        enddo
7972 cgrad      enddo
7973 cgrad      do m=k+1,l-1
7974 cgrad        do ll=1,3
7975 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7976 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7977 cgrad        enddo
7978 cgrad      enddo
7979 cgrad1112  continue
7980 cgrad      do m=i+2,j2
7981 cgrad        do ll=1,3
7982 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7983 cgrad        enddo
7984 cgrad      enddo
7985 cgrad      do m=k+2,l2
7986 cgrad        do ll=1,3
7987 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7988 cgrad        enddo
7989 cgrad      enddo
7990 cd      do iii=1,nres-3
7991 cd        write (2,*) iii,g_corr6_loc(iii)
7992 cd      enddo
7993       eello6=ekont*eel6
7994 cd      write (2,*) 'ekont',ekont
7995 cd      write (iout,*) 'eello6',ekont*eel6
7996       return
7997       end
7998 c--------------------------------------------------------------------------
7999       double precision function eello6_graph1(i,j,k,l,imat,swap)
8000       implicit real*8 (a-h,o-z)
8001       include 'DIMENSIONS'
8002       include 'COMMON.IOUNITS'
8003       include 'COMMON.CHAIN'
8004       include 'COMMON.DERIV'
8005       include 'COMMON.INTERACT'
8006       include 'COMMON.CONTACTS'
8007       include 'COMMON.CONTMAT'
8008       include 'COMMON.CORRMAT'
8009       include 'COMMON.TORSION'
8010       include 'COMMON.VAR'
8011       include 'COMMON.GEO'
8012       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8013       logical swap
8014       logical lprn
8015       common /kutas/ lprn
8016 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8017 C                                                                              C
8018 C      Parallel       Antiparallel                                             C
8019 C                                                                              C
8020 C          o             o                                                     C
8021 C         /l\           /j\                                                    C
8022 C        /   \         /   \                                                   C
8023 C       /| o |         | o |\                                                  C
8024 C     \ j|/k\|  /   \  |/k\|l /                                                C
8025 C      \ /   \ /     \ /   \ /                                                 C
8026 C       o     o       o     o                                                  C
8027 C       i             i                                                        C
8028 C                                                                              C
8029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8030       itk=itype2loc(itype(k))
8031       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8032       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8033       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8034       call transpose2(EUgC(1,1,k),auxmat(1,1))
8035       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8036       vv1(1)=pizda1(1,1)-pizda1(2,2)
8037       vv1(2)=pizda1(1,2)+pizda1(2,1)
8038       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8039       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8040       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8041       s5=scalar2(vv(1),Dtobr2(1,i))
8042 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8043       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8044       if (calc_grad) then
8045       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8046      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8047      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8048      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8049      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8050      & +scalar2(vv(1),Dtobr2der(1,i)))
8051       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8052       vv1(1)=pizda1(1,1)-pizda1(2,2)
8053       vv1(2)=pizda1(1,2)+pizda1(2,1)
8054       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8055       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8056       if (l.eq.j+1) then
8057         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8058      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8059      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8060      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8061      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8062       else
8063         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8064      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8065      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8066      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8067      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8068       endif
8069       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8070       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8071       vv1(1)=pizda1(1,1)-pizda1(2,2)
8072       vv1(2)=pizda1(1,2)+pizda1(2,1)
8073       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8074      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8075      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8076      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8077       do iii=1,2
8078         if (swap) then
8079           ind=3-iii
8080         else
8081           ind=iii
8082         endif
8083         do kkk=1,5
8084           do lll=1,3
8085             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8086             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8087             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8088             call transpose2(EUgC(1,1,k),auxmat(1,1))
8089             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8090      &        pizda1(1,1))
8091             vv1(1)=pizda1(1,1)-pizda1(2,2)
8092             vv1(2)=pizda1(1,2)+pizda1(2,1)
8093             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8094             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8095      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8096             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8097      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8098             s5=scalar2(vv(1),Dtobr2(1,i))
8099             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8100           enddo
8101         enddo
8102       enddo
8103       endif ! calc_grad
8104       return
8105       end
8106 c----------------------------------------------------------------------------
8107       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8108       implicit real*8 (a-h,o-z)
8109       include 'DIMENSIONS'
8110       include 'COMMON.IOUNITS'
8111       include 'COMMON.CHAIN'
8112       include 'COMMON.DERIV'
8113       include 'COMMON.INTERACT'
8114       include 'COMMON.CONTACTS'
8115       include 'COMMON.CONTMAT'
8116       include 'COMMON.CORRMAT'
8117       include 'COMMON.TORSION'
8118       include 'COMMON.VAR'
8119       include 'COMMON.GEO'
8120       logical swap
8121       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8122      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8123       logical lprn
8124       common /kutas/ lprn
8125 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8126 C                                                                              C
8127 C      Parallel       Antiparallel                                             C
8128 C                                                                              C
8129 C          o             o                                                     C
8130 C     \   /l\           /j\   /                                                C
8131 C      \ /   \         /   \ /                                                 C
8132 C       o| o |         | o |o                                                  C
8133 C     \ j|/k\|      \  |/k\|l                                                  C
8134 C      \ /   \       \ /   \                                                   C
8135 C       o             o                                                        C
8136 C       i             i                                                        C
8137 C                                                                              C
8138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8139 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8140 C AL 7/4/01 s1 would occur in the sixth-order moment,
8141 C           but not in a cluster cumulant
8142 #ifdef MOMENT
8143       s1=dip(1,jj,i)*dip(1,kk,k)
8144 #endif
8145       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8146       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8147       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8148       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8149       call transpose2(EUg(1,1,k),auxmat(1,1))
8150       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8151       vv(1)=pizda(1,1)-pizda(2,2)
8152       vv(2)=pizda(1,2)+pizda(2,1)
8153       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8154 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8155 #ifdef MOMENT
8156       eello6_graph2=-(s1+s2+s3+s4)
8157 #else
8158       eello6_graph2=-(s2+s3+s4)
8159 #endif
8160 c      eello6_graph2=-s3
8161 C Derivatives in gamma(i-1)
8162       if (calc_grad) then
8163       if (i.gt.1) then
8164 #ifdef MOMENT
8165         s1=dipderg(1,jj,i)*dip(1,kk,k)
8166 #endif
8167         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8168         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8169         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8170         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8171 #ifdef MOMENT
8172         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8173 #else
8174         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8175 #endif
8176 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8177       endif
8178 C Derivatives in gamma(k-1)
8179 #ifdef MOMENT
8180       s1=dip(1,jj,i)*dipderg(1,kk,k)
8181 #endif
8182       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8183       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8184       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8185       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8186       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8187       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8188       vv(1)=pizda(1,1)-pizda(2,2)
8189       vv(2)=pizda(1,2)+pizda(2,1)
8190       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8191 #ifdef MOMENT
8192       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8193 #else
8194       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8195 #endif
8196 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8197 C Derivatives in gamma(j-1) or gamma(l-1)
8198       if (j.gt.1) then
8199 #ifdef MOMENT
8200         s1=dipderg(3,jj,i)*dip(1,kk,k)
8201 #endif
8202         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8203         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8204         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8205         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8206         vv(1)=pizda(1,1)-pizda(2,2)
8207         vv(2)=pizda(1,2)+pizda(2,1)
8208         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8209 #ifdef MOMENT
8210         if (swap) then
8211           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8212         else
8213           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8214         endif
8215 #endif
8216         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8217 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8218       endif
8219 C Derivatives in gamma(l-1) or gamma(j-1)
8220       if (l.gt.1) then
8221 #ifdef MOMENT
8222         s1=dip(1,jj,i)*dipderg(3,kk,k)
8223 #endif
8224         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8225         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8226         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8227         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8228         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8229         vv(1)=pizda(1,1)-pizda(2,2)
8230         vv(2)=pizda(1,2)+pizda(2,1)
8231         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8232 #ifdef MOMENT
8233         if (swap) then
8234           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8235         else
8236           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8237         endif
8238 #endif
8239         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8240 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8241       endif
8242 C Cartesian derivatives.
8243       if (lprn) then
8244         write (2,*) 'In eello6_graph2'
8245         do iii=1,2
8246           write (2,*) 'iii=',iii
8247           do kkk=1,5
8248             write (2,*) 'kkk=',kkk
8249             do jjj=1,2
8250               write (2,'(3(2f10.5),5x)')
8251      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8252             enddo
8253           enddo
8254         enddo
8255       endif
8256       do iii=1,2
8257         do kkk=1,5
8258           do lll=1,3
8259 #ifdef MOMENT
8260             if (iii.eq.1) then
8261               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8262             else
8263               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8264             endif
8265 #endif
8266             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8267      &        auxvec(1))
8268             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8269             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8270      &        auxvec(1))
8271             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8272             call transpose2(EUg(1,1,k),auxmat(1,1))
8273             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8274      &        pizda(1,1))
8275             vv(1)=pizda(1,1)-pizda(2,2)
8276             vv(2)=pizda(1,2)+pizda(2,1)
8277             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8278 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8279 #ifdef MOMENT
8280             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8281 #else
8282             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8283 #endif
8284             if (swap) then
8285               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8286             else
8287               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8288             endif
8289           enddo
8290         enddo
8291       enddo
8292       endif ! calc_grad
8293       return
8294       end
8295 c----------------------------------------------------------------------------
8296       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8297       implicit real*8 (a-h,o-z)
8298       include 'DIMENSIONS'
8299       include 'COMMON.IOUNITS'
8300       include 'COMMON.CHAIN'
8301       include 'COMMON.DERIV'
8302       include 'COMMON.INTERACT'
8303       include 'COMMON.CONTACTS'
8304       include 'COMMON.CONTMAT'
8305       include 'COMMON.CORRMAT'
8306       include 'COMMON.TORSION'
8307       include 'COMMON.VAR'
8308       include 'COMMON.GEO'
8309       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8310       logical swap
8311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8312 C                                                                              C
8313 C      Parallel       Antiparallel                                             C
8314 C                                                                              C
8315 C          o             o                                                     C
8316 C         /l\   /   \   /j\                                                    C
8317 C        /   \ /     \ /   \                                                   C
8318 C       /| o |o       o| o |\                                                  C
8319 C       j|/k\|  /      |/k\|l /                                                C
8320 C        /   \ /       /   \ /                                                 C
8321 C       /     o       /     o                                                  C
8322 C       i             i                                                        C
8323 C                                                                              C
8324 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8325 C
8326 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8327 C           energy moment and not to the cluster cumulant.
8328       iti=itortyp(itype(i))
8329       if (j.lt.nres-1) then
8330         itj1=itype2loc(itype(j+1))
8331       else
8332         itj1=nloctyp
8333       endif
8334       itk=itype2loc(itype(k))
8335       itk1=itype2loc(itype(k+1))
8336       if (l.lt.nres-1) then
8337         itl1=itype2loc(itype(l+1))
8338       else
8339         itl1=nloctyp
8340       endif
8341 #ifdef MOMENT
8342       s1=dip(4,jj,i)*dip(4,kk,k)
8343 #endif
8344       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8345       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8346       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8347       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8348       call transpose2(EE(1,1,k),auxmat(1,1))
8349       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8350       vv(1)=pizda(1,1)+pizda(2,2)
8351       vv(2)=pizda(2,1)-pizda(1,2)
8352       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8353 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8354 cd     & "sum",-(s2+s3+s4)
8355 #ifdef MOMENT
8356       eello6_graph3=-(s1+s2+s3+s4)
8357 #else
8358       eello6_graph3=-(s2+s3+s4)
8359 #endif
8360 c      eello6_graph3=-s4
8361 C Derivatives in gamma(k-1)
8362       if (calc_grad) then
8363       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8364       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8365       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8366       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8367 C Derivatives in gamma(l-1)
8368       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8369       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8370       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8371       vv(1)=pizda(1,1)+pizda(2,2)
8372       vv(2)=pizda(2,1)-pizda(1,2)
8373       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8374       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8375 C Cartesian derivatives.
8376       do iii=1,2
8377         do kkk=1,5
8378           do lll=1,3
8379 #ifdef MOMENT
8380             if (iii.eq.1) then
8381               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8382             else
8383               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8384             endif
8385 #endif
8386             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8387      &        auxvec(1))
8388             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8389             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8390      &        auxvec(1))
8391             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8392             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8393      &        pizda(1,1))
8394             vv(1)=pizda(1,1)+pizda(2,2)
8395             vv(2)=pizda(2,1)-pizda(1,2)
8396             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8397 #ifdef MOMENT
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8399 #else
8400             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8401 #endif
8402             if (swap) then
8403               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8404             else
8405               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8406             endif
8407 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8408           enddo
8409         enddo
8410       enddo
8411       endif ! calc_grad
8412       return
8413       end
8414 c----------------------------------------------------------------------------
8415       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8416       implicit real*8 (a-h,o-z)
8417       include 'DIMENSIONS'
8418       include 'COMMON.IOUNITS'
8419       include 'COMMON.CHAIN'
8420       include 'COMMON.DERIV'
8421       include 'COMMON.INTERACT'
8422       include 'COMMON.CONTACTS'
8423       include 'COMMON.CONTMAT'
8424       include 'COMMON.CORRMAT'
8425       include 'COMMON.TORSION'
8426       include 'COMMON.VAR'
8427       include 'COMMON.GEO'
8428       include 'COMMON.FFIELD'
8429       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8430      & auxvec1(2),auxmat1(2,2)
8431       logical swap
8432 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8433 C                                                                              C
8434 C      Parallel       Antiparallel                                             C
8435 C                                                                              C
8436 C          o             o                                                     C
8437 C         /l\   /   \   /j\                                                    C
8438 C        /   \ /     \ /   \                                                   C
8439 C       /| o |o       o| o |\                                                  C
8440 C     \ j|/k\|      \  |/k\|l                                                  C
8441 C      \ /   \       \ /   \                                                   C
8442 C       o     \       o     \                                                  C
8443 C       i             i                                                        C
8444 C                                                                              C
8445 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8446 C
8447 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8448 C           energy moment and not to the cluster cumulant.
8449 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8450       iti=itype2loc(itype(i))
8451       itj=itype2loc(itype(j))
8452       if (j.lt.nres-1) then
8453         itj1=itype2loc(itype(j+1))
8454       else
8455         itj1=nloctyp
8456       endif
8457       itk=itype2loc(itype(k))
8458       if (k.lt.nres-1) then
8459         itk1=itype2loc(itype(k+1))
8460       else
8461         itk1=nloctyp
8462       endif
8463       itl=itype2loc(itype(l))
8464       if (l.lt.nres-1) then
8465         itl1=itype2loc(itype(l+1))
8466       else
8467         itl1=nloctyp
8468       endif
8469 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8470 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8471 cd     & ' itl',itl,' itl1',itl1
8472 #ifdef MOMENT
8473       if (imat.eq.1) then
8474         s1=dip(3,jj,i)*dip(3,kk,k)
8475       else
8476         s1=dip(2,jj,j)*dip(2,kk,l)
8477       endif
8478 #endif
8479       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8480       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8481       if (j.eq.l+1) then
8482         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8483         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8484       else
8485         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8486         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8487       endif
8488       call transpose2(EUg(1,1,k),auxmat(1,1))
8489       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8490       vv(1)=pizda(1,1)-pizda(2,2)
8491       vv(2)=pizda(2,1)+pizda(1,2)
8492       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8493 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8494 #ifdef MOMENT
8495       eello6_graph4=-(s1+s2+s3+s4)
8496 #else
8497       eello6_graph4=-(s2+s3+s4)
8498 #endif
8499 C Derivatives in gamma(i-1)
8500       if (calc_grad) then
8501       if (i.gt.1) then
8502 #ifdef MOMENT
8503         if (imat.eq.1) then
8504           s1=dipderg(2,jj,i)*dip(3,kk,k)
8505         else
8506           s1=dipderg(4,jj,j)*dip(2,kk,l)
8507         endif
8508 #endif
8509         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8510         if (j.eq.l+1) then
8511           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8512           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8513         else
8514           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8515           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8516         endif
8517         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8518         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8519 cd          write (2,*) 'turn6 derivatives'
8520 #ifdef MOMENT
8521           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8522 #else
8523           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8524 #endif
8525         else
8526 #ifdef MOMENT
8527           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8528 #else
8529           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8530 #endif
8531         endif
8532       endif
8533 C Derivatives in gamma(k-1)
8534 #ifdef MOMENT
8535       if (imat.eq.1) then
8536         s1=dip(3,jj,i)*dipderg(2,kk,k)
8537       else
8538         s1=dip(2,jj,j)*dipderg(4,kk,l)
8539       endif
8540 #endif
8541       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8542       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8543       if (j.eq.l+1) then
8544         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8545         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8546       else
8547         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8548         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8549       endif
8550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8551       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8552       vv(1)=pizda(1,1)-pizda(2,2)
8553       vv(2)=pizda(2,1)+pizda(1,2)
8554       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8555       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8556 #ifdef MOMENT
8557         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8558 #else
8559         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8560 #endif
8561       else
8562 #ifdef MOMENT
8563         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8564 #else
8565         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8566 #endif
8567       endif
8568 C Derivatives in gamma(j-1) or gamma(l-1)
8569       if (l.eq.j+1 .and. l.gt.1) then
8570         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8571         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8572         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8573         vv(1)=pizda(1,1)-pizda(2,2)
8574         vv(2)=pizda(2,1)+pizda(1,2)
8575         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8576         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8577       else if (j.gt.1) then
8578         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8579         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8580         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8581         vv(1)=pizda(1,1)-pizda(2,2)
8582         vv(2)=pizda(2,1)+pizda(1,2)
8583         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8584         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8585           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8586         else
8587           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8588         endif
8589       endif
8590 C Cartesian derivatives.
8591       do iii=1,2
8592         do kkk=1,5
8593           do lll=1,3
8594 #ifdef MOMENT
8595             if (iii.eq.1) then
8596               if (imat.eq.1) then
8597                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8598               else
8599                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8600               endif
8601             else
8602               if (imat.eq.1) then
8603                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8604               else
8605                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8606               endif
8607             endif
8608 #endif
8609             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8610      &        auxvec(1))
8611             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8612             if (j.eq.l+1) then
8613               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8614      &          b1(1,j+1),auxvec(1))
8615               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8616             else
8617               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8618      &          b1(1,l+1),auxvec(1))
8619               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8620             endif
8621             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8622      &        pizda(1,1))
8623             vv(1)=pizda(1,1)-pizda(2,2)
8624             vv(2)=pizda(2,1)+pizda(1,2)
8625             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8626             if (swap) then
8627               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8628 #ifdef MOMENT
8629                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8630      &             -(s1+s2+s4)
8631 #else
8632                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8633      &             -(s2+s4)
8634 #endif
8635                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8636               else
8637 #ifdef MOMENT
8638                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8639 #else
8640                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8641 #endif
8642                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8643               endif
8644             else
8645 #ifdef MOMENT
8646               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8647 #else
8648               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8649 #endif
8650               if (l.eq.j+1) then
8651                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8652               else
8653                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8654               endif
8655             endif
8656           enddo
8657         enddo
8658       enddo
8659       endif ! calc_grad
8660       return
8661       end
8662 c----------------------------------------------------------------------------
8663       double precision function eello_turn6(i,jj,kk)
8664       implicit real*8 (a-h,o-z)
8665       include 'DIMENSIONS'
8666       include 'COMMON.IOUNITS'
8667       include 'COMMON.CHAIN'
8668       include 'COMMON.DERIV'
8669       include 'COMMON.INTERACT'
8670       include 'COMMON.CONTACTS'
8671       include 'COMMON.CONTMAT'
8672       include 'COMMON.CORRMAT'
8673       include 'COMMON.TORSION'
8674       include 'COMMON.VAR'
8675       include 'COMMON.GEO'
8676       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8677      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8678      &  ggg1(3),ggg2(3)
8679       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8680      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8681 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8682 C           the respective energy moment and not to the cluster cumulant.
8683       s1=0.0d0
8684       s8=0.0d0
8685       s13=0.0d0
8686 c
8687       eello_turn6=0.0d0
8688       j=i+4
8689       k=i+1
8690       l=i+3
8691       iti=itype2loc(itype(i))
8692       itk=itype2loc(itype(k))
8693       itk1=itype2loc(itype(k+1))
8694       itl=itype2loc(itype(l))
8695       itj=itype2loc(itype(j))
8696 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8697 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8698 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8699 cd        eello6=0.0d0
8700 cd        return
8701 cd      endif
8702 cd      write (iout,*)
8703 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8704 cd     &   ' and',k,l
8705 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8706       do iii=1,2
8707         do kkk=1,5
8708           do lll=1,3
8709             derx_turn(lll,kkk,iii)=0.0d0
8710           enddo
8711         enddo
8712       enddo
8713 cd      eij=1.0d0
8714 cd      ekl=1.0d0
8715 cd      ekont=1.0d0
8716       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8717 cd      eello6_5=0.0d0
8718 cd      write (2,*) 'eello6_5',eello6_5
8719 #ifdef MOMENT
8720       call transpose2(AEA(1,1,1),auxmat(1,1))
8721       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8722       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8723       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8724 #endif
8725       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8726       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8727       s2 = scalar2(b1(1,k),vtemp1(1))
8728 #ifdef MOMENT
8729       call transpose2(AEA(1,1,2),atemp(1,1))
8730       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8731       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8732       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8733 #endif
8734       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8735       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8736       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8737 #ifdef MOMENT
8738       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8739       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8740       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8741       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8742       ss13 = scalar2(b1(1,k),vtemp4(1))
8743       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8744 #endif
8745 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8746 c      s1=0.0d0
8747 c      s2=0.0d0
8748 c      s8=0.0d0
8749 c      s12=0.0d0
8750 c      s13=0.0d0
8751       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8752 C Derivatives in gamma(i+2)
8753       if (calc_grad) then
8754       s1d =0.0d0
8755       s8d =0.0d0
8756 #ifdef MOMENT
8757       call transpose2(AEA(1,1,1),auxmatd(1,1))
8758       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8759       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8760       call transpose2(AEAderg(1,1,2),atempd(1,1))
8761       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8762       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8763 #endif
8764       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8765       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8766       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8767 c      s1d=0.0d0
8768 c      s2d=0.0d0
8769 c      s8d=0.0d0
8770 c      s12d=0.0d0
8771 c      s13d=0.0d0
8772       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8773 C Derivatives in gamma(i+3)
8774 #ifdef MOMENT
8775       call transpose2(AEA(1,1,1),auxmatd(1,1))
8776       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8777       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8778       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8779 #endif
8780       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8781       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8782       s2d = scalar2(b1(1,k),vtemp1d(1))
8783 #ifdef MOMENT
8784       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8785       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8786 #endif
8787       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8788 #ifdef MOMENT
8789       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8790       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8791       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8792 #endif
8793 c      s1d=0.0d0
8794 c      s2d=0.0d0
8795 c      s8d=0.0d0
8796 c      s12d=0.0d0
8797 c      s13d=0.0d0
8798 #ifdef MOMENT
8799       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8800      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8801 #else
8802       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8803      &               -0.5d0*ekont*(s2d+s12d)
8804 #endif
8805 C Derivatives in gamma(i+4)
8806       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8807       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8808       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8809 #ifdef MOMENT
8810       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8811       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8812       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8813 #endif
8814 c      s1d=0.0d0
8815 c      s2d=0.0d0
8816 c      s8d=0.0d0
8817 C      s12d=0.0d0
8818 c      s13d=0.0d0
8819 #ifdef MOMENT
8820       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8821 #else
8822       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8823 #endif
8824 C Derivatives in gamma(i+5)
8825 #ifdef MOMENT
8826       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8827       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8828       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8829 #endif
8830       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8831       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8832       s2d = scalar2(b1(1,k),vtemp1d(1))
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,2),atempd(1,1))
8835       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8836       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8837 #endif
8838       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8839       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8840 #ifdef MOMENT
8841       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8842       ss13d = scalar2(b1(1,k),vtemp4d(1))
8843       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8844 #endif
8845 c      s1d=0.0d0
8846 c      s2d=0.0d0
8847 c      s8d=0.0d0
8848 c      s12d=0.0d0
8849 c      s13d=0.0d0
8850 #ifdef MOMENT
8851       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8852      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8853 #else
8854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8855      &               -0.5d0*ekont*(s2d+s12d)
8856 #endif
8857 C Cartesian derivatives
8858       do iii=1,2
8859         do kkk=1,5
8860           do lll=1,3
8861 #ifdef MOMENT
8862             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8863             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8864             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8865 #endif
8866             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8867             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8868      &          vtemp1d(1))
8869             s2d = scalar2(b1(1,k),vtemp1d(1))
8870 #ifdef MOMENT
8871             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8872             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8873             s8d = -(atempd(1,1)+atempd(2,2))*
8874      &           scalar2(cc(1,1,l),vtemp2(1))
8875 #endif
8876             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8877      &           auxmatd(1,1))
8878             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8879             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8880 c      s1d=0.0d0
8881 c      s2d=0.0d0
8882 c      s8d=0.0d0
8883 c      s12d=0.0d0
8884 c      s13d=0.0d0
8885 #ifdef MOMENT
8886             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8887      &        - 0.5d0*(s1d+s2d)
8888 #else
8889             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8890      &        - 0.5d0*s2d
8891 #endif
8892 #ifdef MOMENT
8893             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8894      &        - 0.5d0*(s8d+s12d)
8895 #else
8896             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8897      &        - 0.5d0*s12d
8898 #endif
8899           enddo
8900         enddo
8901       enddo
8902 #ifdef MOMENT
8903       do kkk=1,5
8904         do lll=1,3
8905           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8906      &      achuj_tempd(1,1))
8907           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8908           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8909           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8910           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8911           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8912      &      vtemp4d(1))
8913           ss13d = scalar2(b1(1,k),vtemp4d(1))
8914           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8915           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8916         enddo
8917       enddo
8918 #endif
8919 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8920 cd     &  16*eel_turn6_num
8921 cd      goto 1112
8922       if (j.lt.nres-1) then
8923         j1=j+1
8924         j2=j-1
8925       else
8926         j1=j-1
8927         j2=j-2
8928       endif
8929       if (l.lt.nres-1) then
8930         l1=l+1
8931         l2=l-1
8932       else
8933         l1=l-1
8934         l2=l-2
8935       endif
8936       do ll=1,3
8937 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8938 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8939 cgrad        ghalf=0.5d0*ggg1(ll)
8940 cd        ghalf=0.0d0
8941         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8942         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8943         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8944      &    +ekont*derx_turn(ll,2,1)
8945         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8946         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8947      &    +ekont*derx_turn(ll,4,1)
8948         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8949         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8950         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8951 cgrad        ghalf=0.5d0*ggg2(ll)
8952 cd        ghalf=0.0d0
8953         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8954      &    +ekont*derx_turn(ll,2,2)
8955         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8956         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8957      &    +ekont*derx_turn(ll,4,2)
8958         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8959         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8960         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8961       enddo
8962 cd      goto 1112
8963 cgrad      do m=i+1,j-1
8964 cgrad        do ll=1,3
8965 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8966 cgrad        enddo
8967 cgrad      enddo
8968 cgrad      do m=k+1,l-1
8969 cgrad        do ll=1,3
8970 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8971 cgrad        enddo
8972 cgrad      enddo
8973 cgrad1112  continue
8974 cgrad      do m=i+2,j2
8975 cgrad        do ll=1,3
8976 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8977 cgrad        enddo
8978 cgrad      enddo
8979 cgrad      do m=k+2,l2
8980 cgrad        do ll=1,3
8981 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8982 cgrad        enddo
8983 cgrad      enddo
8984 cd      do iii=1,nres-3
8985 cd        write (2,*) iii,g_corr6_loc(iii)
8986 cd      enddo
8987       endif ! calc_grad
8988       eello_turn6=ekont*eel_turn6
8989 cd      write (2,*) 'ekont',ekont
8990 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8991       return
8992       end
8993 #endif
8994 crc-------------------------------------------------
8995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8996       subroutine Eliptransfer(eliptran)
8997       implicit real*8 (a-h,o-z)
8998       include 'DIMENSIONS'
8999       include 'COMMON.GEO'
9000       include 'COMMON.VAR'
9001       include 'COMMON.LOCAL'
9002       include 'COMMON.CHAIN'
9003       include 'COMMON.DERIV'
9004       include 'COMMON.INTERACT'
9005       include 'COMMON.IOUNITS'
9006       include 'COMMON.CALC'
9007       include 'COMMON.CONTROL'
9008       include 'COMMON.SPLITELE'
9009       include 'COMMON.SBRIDGE'
9010 C this is done by Adasko
9011 C      print *,"wchodze"
9012 C structure of box:
9013 C      water
9014 C--bordliptop-- buffore starts
9015 C--bufliptop--- here true lipid starts
9016 C      lipid
9017 C--buflipbot--- lipid ends buffore starts
9018 C--bordlipbot--buffore ends
9019       eliptran=0.0
9020       do i=1,nres
9021 C       do i=1,1
9022         if (itype(i).eq.ntyp1) cycle
9023
9024         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9025         if (positi.le.0) positi=positi+boxzsize
9026 C        print *,i
9027 C first for peptide groups
9028 c for each residue check if it is in lipid or lipid water border area
9029        if ((positi.gt.bordlipbot)
9030      &.and.(positi.lt.bordliptop)) then
9031 C the energy transfer exist
9032         if (positi.lt.buflipbot) then
9033 C what fraction I am in
9034          fracinbuf=1.0d0-
9035      &        ((positi-bordlipbot)/lipbufthick)
9036 C lipbufthick is thickenes of lipid buffore
9037          sslip=sscalelip(fracinbuf)
9038          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9039          eliptran=eliptran+sslip*pepliptran
9040          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9041          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9042 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9043         elseif (positi.gt.bufliptop) then
9044          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9045          sslip=sscalelip(fracinbuf)
9046          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9047          eliptran=eliptran+sslip*pepliptran
9048          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9049          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9050 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9051 C          print *, "doing sscalefor top part"
9052 C         print *,i,sslip,fracinbuf,ssgradlip
9053         else
9054          eliptran=eliptran+pepliptran
9055 C         print *,"I am in true lipid"
9056         endif
9057 C       else
9058 C       eliptran=elpitran+0.0 ! I am in water
9059        endif
9060        enddo
9061 C       print *, "nic nie bylo w lipidzie?"
9062 C now multiply all by the peptide group transfer factor
9063 C       eliptran=eliptran*pepliptran
9064 C now the same for side chains
9065 CV       do i=1,1
9066        do i=1,nres
9067         if (itype(i).eq.ntyp1) cycle
9068         positi=(mod(c(3,i+nres),boxzsize))
9069         if (positi.le.0) positi=positi+boxzsize
9070 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9071 c for each residue check if it is in lipid or lipid water border area
9072 C       respos=mod(c(3,i+nres),boxzsize)
9073 C       print *,positi,bordlipbot,buflipbot
9074        if ((positi.gt.bordlipbot)
9075      & .and.(positi.lt.bordliptop)) then
9076 C the energy transfer exist
9077         if (positi.lt.buflipbot) then
9078          fracinbuf=1.0d0-
9079      &     ((positi-bordlipbot)/lipbufthick)
9080 C lipbufthick is thickenes of lipid buffore
9081          sslip=sscalelip(fracinbuf)
9082          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9083          eliptran=eliptran+sslip*liptranene(itype(i))
9084          gliptranx(3,i)=gliptranx(3,i)
9085      &+ssgradlip*liptranene(itype(i))
9086          gliptranc(3,i-1)= gliptranc(3,i-1)
9087      &+ssgradlip*liptranene(itype(i))
9088 C         print *,"doing sccale for lower part"
9089         elseif (positi.gt.bufliptop) then
9090          fracinbuf=1.0d0-
9091      &((bordliptop-positi)/lipbufthick)
9092          sslip=sscalelip(fracinbuf)
9093          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9094          eliptran=eliptran+sslip*liptranene(itype(i))
9095          gliptranx(3,i)=gliptranx(3,i)
9096      &+ssgradlip*liptranene(itype(i))
9097          gliptranc(3,i-1)= gliptranc(3,i-1)
9098      &+ssgradlip*liptranene(itype(i))
9099 C          print *, "doing sscalefor top part",sslip,fracinbuf
9100         else
9101          eliptran=eliptran+liptranene(itype(i))
9102 C         print *,"I am in true lipid"
9103         endif
9104         endif ! if in lipid or buffor
9105 C       else
9106 C       eliptran=elpitran+0.0 ! I am in water
9107        enddo
9108        return
9109        end
9110
9111
9112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9113
9114       SUBROUTINE MATVEC2(A1,V1,V2)
9115       implicit real*8 (a-h,o-z)
9116       include 'DIMENSIONS'
9117       DIMENSION A1(2,2),V1(2),V2(2)
9118 c      DO 1 I=1,2
9119 c        VI=0.0
9120 c        DO 3 K=1,2
9121 c    3     VI=VI+A1(I,K)*V1(K)
9122 c        Vaux(I)=VI
9123 c    1 CONTINUE
9124
9125       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9126       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9127
9128       v2(1)=vaux1
9129       v2(2)=vaux2
9130       END
9131 C---------------------------------------
9132       SUBROUTINE MATMAT2(A1,A2,A3)
9133       implicit real*8 (a-h,o-z)
9134       include 'DIMENSIONS'
9135       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9136 c      DIMENSION AI3(2,2)
9137 c        DO  J=1,2
9138 c          A3IJ=0.0
9139 c          DO K=1,2
9140 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9141 c          enddo
9142 c          A3(I,J)=A3IJ
9143 c       enddo
9144 c      enddo
9145
9146       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9147       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9148       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9149       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9150
9151       A3(1,1)=AI3_11
9152       A3(2,1)=AI3_21
9153       A3(1,2)=AI3_12
9154       A3(2,2)=AI3_22
9155       END
9156
9157 c-------------------------------------------------------------------------
9158       double precision function scalar2(u,v)
9159       implicit none
9160       double precision u(2),v(2)
9161       double precision sc
9162       integer i
9163       scalar2=u(1)*v(1)+u(2)*v(2)
9164       return
9165       end
9166
9167 C-----------------------------------------------------------------------------
9168
9169       subroutine transpose2(a,at)
9170       implicit none
9171       double precision a(2,2),at(2,2)
9172       at(1,1)=a(1,1)
9173       at(1,2)=a(2,1)
9174       at(2,1)=a(1,2)
9175       at(2,2)=a(2,2)
9176       return
9177       end
9178 c--------------------------------------------------------------------------
9179       subroutine transpose(n,a,at)
9180       implicit none
9181       integer n,i,j
9182       double precision a(n,n),at(n,n)
9183       do i=1,n
9184         do j=1,n
9185           at(j,i)=a(i,j)
9186         enddo
9187       enddo
9188       return
9189       end
9190 C---------------------------------------------------------------------------
9191       subroutine prodmat3(a1,a2,kk,transp,prod)
9192       implicit none
9193       integer i,j
9194       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9195       logical transp
9196 crc      double precision auxmat(2,2),prod_(2,2)
9197
9198       if (transp) then
9199 crc        call transpose2(kk(1,1),auxmat(1,1))
9200 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9201 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9202
9203            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9204      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9205            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9206      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9207            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9208      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9209            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9210      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9211
9212       else
9213 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9214 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9215
9216            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9217      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9218            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9219      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9220            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9221      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9222            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9223      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9224
9225       endif
9226 c      call transpose2(a2(1,1),a2t(1,1))
9227
9228 crc      print *,transp
9229 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9230 crc      print *,((prod(i,j),i=1,2),j=1,2)
9231
9232       return
9233       end
9234 C-----------------------------------------------------------------------------
9235       double precision function scalar(u,v)
9236       implicit none
9237       double precision u(3),v(3)
9238       double precision sc
9239       integer i
9240       sc=0.0d0
9241       do i=1,3
9242         sc=sc+u(i)*v(i)
9243       enddo
9244       scalar=sc
9245       return
9246       end
9247 C-----------------------------------------------------------------------
9248       double precision function sscale(r)
9249       double precision r,gamm
9250       include "COMMON.SPLITELE"
9251       if(r.lt.r_cut-rlamb) then
9252         sscale=1.0d0
9253       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9254         gamm=(r-(r_cut-rlamb))/rlamb
9255         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9256       else
9257         sscale=0d0
9258       endif
9259       return
9260       end
9261 C-----------------------------------------------------------------------
9262 C-----------------------------------------------------------------------
9263       double precision function sscagrad(r)
9264       double precision r,gamm
9265       include "COMMON.SPLITELE"
9266       if(r.lt.r_cut-rlamb) then
9267         sscagrad=0.0d0
9268       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9269         gamm=(r-(r_cut-rlamb))/rlamb
9270         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9271       else
9272         sscagrad=0.0d0
9273       endif
9274       return
9275       end
9276 C-----------------------------------------------------------------------
9277 C-----------------------------------------------------------------------
9278       double precision function sscalelip(r)
9279       double precision r,gamm
9280       include "COMMON.SPLITELE"
9281 C      if(r.lt.r_cut-rlamb) then
9282 C        sscale=1.0d0
9283 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9284 C        gamm=(r-(r_cut-rlamb))/rlamb
9285         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9286 C      else
9287 C        sscale=0d0
9288 C      endif
9289       return
9290       end
9291 C-----------------------------------------------------------------------
9292       double precision function sscagradlip(r)
9293       double precision r,gamm
9294       include "COMMON.SPLITELE"
9295 C     if(r.lt.r_cut-rlamb) then
9296 C        sscagrad=0.0d0
9297 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9298 C        gamm=(r-(r_cut-rlamb))/rlamb
9299         sscagradlip=r*(6*r-6.0d0)
9300 C      else
9301 C        sscagrad=0.0d0
9302 C      endif
9303       return
9304       end
9305
9306 C-----------------------------------------------------------------------
9307        subroutine set_shield_fac
9308       implicit real*8 (a-h,o-z)
9309       include 'DIMENSIONS'
9310       include 'COMMON.CHAIN'
9311       include 'COMMON.DERIV'
9312       include 'COMMON.IOUNITS'
9313       include 'COMMON.SHIELD'
9314       include 'COMMON.INTERACT'
9315 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9316       double precision div77_81/0.974996043d0/,
9317      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9318
9319 C the vector between center of side_chain and peptide group
9320        double precision pep_side(3),long,side_calf(3),
9321      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9322      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9323 C the line belowe needs to be changed for FGPROC>1
9324       do i=1,nres-1
9325       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9326       ishield_list(i)=0
9327 Cif there two consequtive dummy atoms there is no peptide group between them
9328 C the line below has to be changed for FGPROC>1
9329       VolumeTotal=0.0
9330       do k=1,nres
9331        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9332        dist_pep_side=0.0
9333        dist_side_calf=0.0
9334        do j=1,3
9335 C first lets set vector conecting the ithe side-chain with kth side-chain
9336       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9337 C      pep_side(j)=2.0d0
9338 C and vector conecting the side-chain with its proper calfa
9339       side_calf(j)=c(j,k+nres)-c(j,k)
9340 C      side_calf(j)=2.0d0
9341       pept_group(j)=c(j,i)-c(j,i+1)
9342 C lets have their lenght
9343       dist_pep_side=pep_side(j)**2+dist_pep_side
9344       dist_side_calf=dist_side_calf+side_calf(j)**2
9345       dist_pept_group=dist_pept_group+pept_group(j)**2
9346       enddo
9347        dist_pep_side=dsqrt(dist_pep_side)
9348        dist_pept_group=dsqrt(dist_pept_group)
9349        dist_side_calf=dsqrt(dist_side_calf)
9350       do j=1,3
9351         pep_side_norm(j)=pep_side(j)/dist_pep_side
9352         side_calf_norm(j)=dist_side_calf
9353       enddo
9354 C now sscale fraction
9355        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9356 C       print *,buff_shield,"buff"
9357 C now sscale
9358         if (sh_frac_dist.le.0.0) cycle
9359 C If we reach here it means that this side chain reaches the shielding sphere
9360 C Lets add him to the list for gradient
9361         ishield_list(i)=ishield_list(i)+1
9362 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9363 C this list is essential otherwise problem would be O3
9364         shield_list(ishield_list(i),i)=k
9365 C Lets have the sscale value
9366         if (sh_frac_dist.gt.1.0) then
9367          scale_fac_dist=1.0d0
9368          do j=1,3
9369          sh_frac_dist_grad(j)=0.0d0
9370          enddo
9371         else
9372          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9373      &                   *(2.0*sh_frac_dist-3.0d0)
9374          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9375      &                  /dist_pep_side/buff_shield*0.5
9376 C remember for the final gradient multiply sh_frac_dist_grad(j)
9377 C for side_chain by factor -2 !
9378          do j=1,3
9379          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9380 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9381 C     &                    sh_frac_dist_grad(j)
9382          enddo
9383         endif
9384 C        if ((i.eq.3).and.(k.eq.2)) then
9385 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9386 C     & ,"TU"
9387 C        endif
9388
9389 C this is what is now we have the distance scaling now volume...
9390       short=short_r_sidechain(itype(k))
9391       long=long_r_sidechain(itype(k))
9392       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9393 C now costhet_grad
9394 C       costhet=0.0d0
9395        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9396 C       costhet_fac=0.0d0
9397        do j=1,3
9398          costhet_grad(j)=costhet_fac*pep_side(j)
9399        enddo
9400 C remember for the final gradient multiply costhet_grad(j)
9401 C for side_chain by factor -2 !
9402 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9403 C pep_side0pept_group is vector multiplication
9404       pep_side0pept_group=0.0
9405       do j=1,3
9406       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9407       enddo
9408       cosalfa=(pep_side0pept_group/
9409      & (dist_pep_side*dist_side_calf))
9410       fac_alfa_sin=1.0-cosalfa**2
9411       fac_alfa_sin=dsqrt(fac_alfa_sin)
9412       rkprim=fac_alfa_sin*(long-short)+short
9413 C now costhet_grad
9414        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9415        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9416
9417        do j=1,3
9418          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9419      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9420      &*(long-short)/fac_alfa_sin*cosalfa/
9421      &((dist_pep_side*dist_side_calf))*
9422      &((side_calf(j))-cosalfa*
9423      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9424
9425         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9426      &*(long-short)/fac_alfa_sin*cosalfa
9427      &/((dist_pep_side*dist_side_calf))*
9428      &(pep_side(j)-
9429      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9430        enddo
9431
9432       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9433      &                    /VSolvSphere_div
9434      &                    *wshield
9435 C now the gradient...
9436 C grad_shield is gradient of Calfa for peptide groups
9437 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9438 C     &               costhet,cosphi
9439 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9440 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9441       do j=1,3
9442       grad_shield(j,i)=grad_shield(j,i)
9443 C gradient po skalowaniu
9444      &                +(sh_frac_dist_grad(j)
9445 C  gradient po costhet
9446      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9447      &-scale_fac_dist*(cosphi_grad_long(j))
9448      &/(1.0-cosphi) )*div77_81
9449      &*VofOverlap
9450 C grad_shield_side is Cbeta sidechain gradient
9451       grad_shield_side(j,ishield_list(i),i)=
9452      &        (sh_frac_dist_grad(j)*(-2.0d0)
9453      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9454      &       +scale_fac_dist*(cosphi_grad_long(j))
9455      &        *2.0d0/(1.0-cosphi))
9456      &        *div77_81*VofOverlap
9457
9458        grad_shield_loc(j,ishield_list(i),i)=
9459      &   scale_fac_dist*cosphi_grad_loc(j)
9460      &        *2.0d0/(1.0-cosphi)
9461      &        *div77_81*VofOverlap
9462       enddo
9463       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9464       enddo
9465       fac_shield(i)=VolumeTotal*div77_81+div4_81
9466 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9467       enddo
9468       return
9469       end
9470 C--------------------------------------------------------------------------
9471 C first for shielding is setting of function of side-chains
9472        subroutine set_shield_fac2
9473       implicit real*8 (a-h,o-z)
9474       include 'DIMENSIONS'
9475       include 'COMMON.CHAIN'
9476       include 'COMMON.DERIV'
9477       include 'COMMON.IOUNITS'
9478       include 'COMMON.SHIELD'
9479       include 'COMMON.INTERACT'
9480 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9481       double precision div77_81/0.974996043d0/,
9482      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9483
9484 C the vector between center of side_chain and peptide group
9485        double precision pep_side(3),long,side_calf(3),
9486      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9487      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9488 C the line belowe needs to be changed for FGPROC>1
9489       do i=1,nres-1
9490       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9491       ishield_list(i)=0
9492 Cif there two consequtive dummy atoms there is no peptide group between them
9493 C the line below has to be changed for FGPROC>1
9494       VolumeTotal=0.0
9495       do k=1,nres
9496        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9497        dist_pep_side=0.0
9498        dist_side_calf=0.0
9499        do j=1,3
9500 C first lets set vector conecting the ithe side-chain with kth side-chain
9501       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9502 C      pep_side(j)=2.0d0
9503 C and vector conecting the side-chain with its proper calfa
9504       side_calf(j)=c(j,k+nres)-c(j,k)
9505 C      side_calf(j)=2.0d0
9506       pept_group(j)=c(j,i)-c(j,i+1)
9507 C lets have their lenght
9508       dist_pep_side=pep_side(j)**2+dist_pep_side
9509       dist_side_calf=dist_side_calf+side_calf(j)**2
9510       dist_pept_group=dist_pept_group+pept_group(j)**2
9511       enddo
9512        dist_pep_side=dsqrt(dist_pep_side)
9513        dist_pept_group=dsqrt(dist_pept_group)
9514        dist_side_calf=dsqrt(dist_side_calf)
9515       do j=1,3
9516         pep_side_norm(j)=pep_side(j)/dist_pep_side
9517         side_calf_norm(j)=dist_side_calf
9518       enddo
9519 C now sscale fraction
9520        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9521 C       print *,buff_shield,"buff"
9522 C now sscale
9523         if (sh_frac_dist.le.0.0) cycle
9524 C If we reach here it means that this side chain reaches the shielding sphere
9525 C Lets add him to the list for gradient
9526         ishield_list(i)=ishield_list(i)+1
9527 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9528 C this list is essential otherwise problem would be O3
9529         shield_list(ishield_list(i),i)=k
9530 C Lets have the sscale value
9531         if (sh_frac_dist.gt.1.0) then
9532          scale_fac_dist=1.0d0
9533          do j=1,3
9534          sh_frac_dist_grad(j)=0.0d0
9535          enddo
9536         else
9537          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9538      &                   *(2.0d0*sh_frac_dist-3.0d0)
9539          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9540      &                  /dist_pep_side/buff_shield*0.5d0
9541 C remember for the final gradient multiply sh_frac_dist_grad(j)
9542 C for side_chain by factor -2 !
9543          do j=1,3
9544          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9545 C         sh_frac_dist_grad(j)=0.0d0
9546 C         scale_fac_dist=1.0d0
9547 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9548 C     &                    sh_frac_dist_grad(j)
9549          enddo
9550         endif
9551 C this is what is now we have the distance scaling now volume...
9552       short=short_r_sidechain(itype(k))
9553       long=long_r_sidechain(itype(k))
9554       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9555       sinthet=short/dist_pep_side*costhet
9556 C now costhet_grad
9557 C       costhet=0.6d0
9558 C       sinthet=0.8
9559        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9560 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9561 C     &             -short/dist_pep_side**2/costhet)
9562 C       costhet_fac=0.0d0
9563        do j=1,3
9564          costhet_grad(j)=costhet_fac*pep_side(j)
9565        enddo
9566 C remember for the final gradient multiply costhet_grad(j)
9567 C for side_chain by factor -2 !
9568 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9569 C pep_side0pept_group is vector multiplication
9570       pep_side0pept_group=0.0d0
9571       do j=1,3
9572       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9573       enddo
9574       cosalfa=(pep_side0pept_group/
9575      & (dist_pep_side*dist_side_calf))
9576       fac_alfa_sin=1.0d0-cosalfa**2
9577       fac_alfa_sin=dsqrt(fac_alfa_sin)
9578       rkprim=fac_alfa_sin*(long-short)+short
9579 C      rkprim=short
9580
9581 C now costhet_grad
9582        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9583 C       cosphi=0.6
9584        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9585        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9586      &      dist_pep_side**2)
9587 C       sinphi=0.8
9588        do j=1,3
9589          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9590      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9591      &*(long-short)/fac_alfa_sin*cosalfa/
9592      &((dist_pep_side*dist_side_calf))*
9593      &((side_calf(j))-cosalfa*
9594      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9595 C       cosphi_grad_long(j)=0.0d0
9596         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9597      &*(long-short)/fac_alfa_sin*cosalfa
9598      &/((dist_pep_side*dist_side_calf))*
9599      &(pep_side(j)-
9600      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9601 C       cosphi_grad_loc(j)=0.0d0
9602        enddo
9603 C      print *,sinphi,sinthet
9604       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9605      &                    /VSolvSphere_div
9606 C     &                    *wshield
9607 C now the gradient...
9608       do j=1,3
9609       grad_shield(j,i)=grad_shield(j,i)
9610 C gradient po skalowaniu
9611      &                +(sh_frac_dist_grad(j)*VofOverlap
9612 C  gradient po costhet
9613      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9614      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9615      &       sinphi/sinthet*costhet*costhet_grad(j)
9616      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9617      & )*wshield
9618 C grad_shield_side is Cbeta sidechain gradient
9619       grad_shield_side(j,ishield_list(i),i)=
9620      &        (sh_frac_dist_grad(j)*(-2.0d0)
9621      &        *VofOverlap
9622      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9623      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9624      &       sinphi/sinthet*costhet*costhet_grad(j)
9625      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9626      &       )*wshield
9627
9628        grad_shield_loc(j,ishield_list(i),i)=
9629      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9630      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9631      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9632      &        ))
9633      &        *wshield
9634       enddo
9635       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9636       enddo
9637       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9638 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9639 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9640       enddo
9641       return
9642       end
9643 C--------------------------------------------------------------------------
9644       double precision function tschebyshev(m,n,x,y)
9645       implicit none
9646       include "DIMENSIONS"
9647       integer i,m,n
9648       double precision x(n),y,yy(0:maxvar),aux
9649 c Tschebyshev polynomial. Note that the first term is omitted
9650 c m=0: the constant term is included
9651 c m=1: the constant term is not included
9652       yy(0)=1.0d0
9653       yy(1)=y
9654       do i=2,n
9655         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9656       enddo
9657       aux=0.0d0
9658       do i=m,n
9659         aux=aux+x(i)*yy(i)
9660       enddo
9661       tschebyshev=aux
9662       return
9663       end
9664 C--------------------------------------------------------------------------
9665       double precision function gradtschebyshev(m,n,x,y)
9666       implicit none
9667       include "DIMENSIONS"
9668       integer i,m,n
9669       double precision x(n+1),y,yy(0:maxvar),aux
9670 c Tschebyshev polynomial. Note that the first term is omitted
9671 c m=0: the constant term is included
9672 c m=1: the constant term is not included
9673       yy(0)=1.0d0
9674       yy(1)=2.0d0*y
9675       do i=2,n
9676         yy(i)=2*y*yy(i-1)-yy(i-2)
9677       enddo
9678       aux=0.0d0
9679       do i=m,n
9680         aux=aux+x(i+1)*yy(i)*(i+1)
9681 C        print *, x(i+1),yy(i),i
9682       enddo
9683       gradtschebyshev=aux
9684       return
9685       end
9686 c----------------------------------------------------------------------------
9687       double precision function sscale2(r,r_cut,r0,rlamb)
9688       implicit none
9689       double precision r,gamm,r_cut,r0,rlamb,rr
9690       rr = dabs(r-r0)
9691 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9692 c      write (2,*) "rr",rr
9693       if(rr.lt.r_cut-rlamb) then
9694         sscale2=1.0d0
9695       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9696         gamm=(rr-(r_cut-rlamb))/rlamb
9697         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9698       else
9699         sscale2=0d0
9700       endif
9701       return
9702       end
9703 C-----------------------------------------------------------------------
9704       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9705       implicit none
9706       double precision r,gamm,r_cut,r0,rlamb,rr
9707       rr = dabs(r-r0)
9708       if(rr.lt.r_cut-rlamb) then
9709         sscalgrad2=0.0d0
9710       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9711         gamm=(rr-(r_cut-rlamb))/rlamb
9712         if (r.ge.r0) then
9713           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9714         else
9715           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9716         endif
9717       else
9718         sscalgrad2=0.0d0
9719       endif
9720       return
9721       end
9722 c----------------------------------------------------------------------------
9723       subroutine e_saxs(Esaxs_constr)
9724       implicit none
9725       include 'DIMENSIONS'
9726 #ifdef MPI
9727       include "mpif.h"
9728       include "COMMON.SETUP"
9729       integer IERR
9730 #endif
9731       include 'COMMON.SBRIDGE'
9732       include 'COMMON.CHAIN'
9733       include 'COMMON.GEO'
9734       include 'COMMON.LOCAL'
9735       include 'COMMON.INTERACT'
9736       include 'COMMON.VAR'
9737       include 'COMMON.IOUNITS'
9738       include 'COMMON.DERIV'
9739       include 'COMMON.CONTROL'
9740       include 'COMMON.NAMES'
9741       include 'COMMON.FFIELD'
9742       include 'COMMON.LANGEVIN'
9743       include 'COMMON.SAXS'
9744 c
9745       double precision Esaxs_constr
9746       integer i,iint,j,k,l
9747       double precision PgradC(maxSAXS,3,maxres),
9748      &  PgradX(maxSAXS,3,maxres)
9749 #ifdef MPI
9750       double precision PgradC_(maxSAXS,3,maxres),
9751      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9752 #endif
9753       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9754      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9755      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9756      & auxX,auxX1,CACAgrad,Cnorm
9757       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9758       double precision dist
9759       external dist
9760 c  SAXS restraint penalty function
9761 #ifdef DEBUG
9762       write(iout,*) "------- SAXS penalty function start -------"
9763       write (iout,*) "nsaxs",nsaxs
9764       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9765       write (iout,*) "Psaxs"
9766       do i=1,nsaxs
9767         write (iout,'(i5,e15.5)') i, Psaxs(i)
9768       enddo
9769 #endif
9770       Esaxs_constr = 0.0d0
9771       do k=1,nsaxs
9772         Pcalc(k)=0.0d0
9773         do j=1,nres
9774           do l=1,3
9775             PgradC(k,l,j)=0.0d0
9776             PgradX(k,l,j)=0.0d0
9777           enddo
9778         enddo
9779       enddo
9780       do i=iatsc_s,iatsc_e
9781        if (itype(i).eq.ntyp1) cycle
9782        do iint=1,nint_gr(i)
9783          do j=istart(i,iint),iend(i,iint)
9784            if (itype(j).eq.ntyp1) cycle
9785 #ifdef ALLSAXS
9786            dijCACA=dist(i,j)
9787            dijCASC=dist(i,j+nres)
9788            dijSCCA=dist(i+nres,j)
9789            dijSCSC=dist(i+nres,j+nres)
9790            sigma2CACA=2.0d0/(pstok**2)
9791            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9792            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9793            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9794            do k=1,nsaxs
9795              dk = distsaxs(k)
9796              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9797              if (itype(j).ne.10) then
9798              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9799              else
9800              endif
9801              expCASC = 0.0d0
9802              if (itype(i).ne.10) then
9803              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9804              else
9805              expSCCA = 0.0d0
9806              endif
9807              if (itype(i).ne.10 .and. itype(j).ne.10) then
9808              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9809              else
9810              expSCSC = 0.0d0
9811              endif
9812              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9813 #ifdef DEBUG
9814              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9815 #endif
9816              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9817              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9818              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9819              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9820              do l=1,3
9821 c CA CA
9822                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9823                PgradC(k,l,i) = PgradC(k,l,i)-aux
9824                PgradC(k,l,j) = PgradC(k,l,j)+aux
9825 c CA SC
9826                if (itype(j).ne.10) then
9827                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9828                PgradC(k,l,i) = PgradC(k,l,i)-aux
9829                PgradC(k,l,j) = PgradC(k,l,j)+aux
9830                PgradX(k,l,j) = PgradX(k,l,j)+aux
9831                endif
9832 c SC CA
9833                if (itype(i).ne.10) then
9834                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9835                PgradX(k,l,i) = PgradX(k,l,i)-aux
9836                PgradC(k,l,i) = PgradC(k,l,i)-aux
9837                PgradC(k,l,j) = PgradC(k,l,j)+aux
9838                endif
9839 c SC SC
9840                if (itype(i).ne.10 .and. itype(j).ne.10) then
9841                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9842                PgradC(k,l,i) = PgradC(k,l,i)-aux
9843                PgradC(k,l,j) = PgradC(k,l,j)+aux
9844                PgradX(k,l,i) = PgradX(k,l,i)-aux
9845                PgradX(k,l,j) = PgradX(k,l,j)+aux
9846                endif
9847              enddo ! l
9848            enddo ! k
9849 #else
9850            dijCACA=dist(i,j)
9851            sigma2CACA=scal_rad**2*0.25d0/
9852      &        (restok(itype(j))**2+restok(itype(i))**2)
9853
9854            IF (saxs_cutoff.eq.0) THEN
9855            do k=1,nsaxs
9856              dk = distsaxs(k)
9857              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9858              Pcalc(k) = Pcalc(k)+expCACA
9859              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9860              do l=1,3
9861                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9862                PgradC(k,l,i) = PgradC(k,l,i)-aux
9863                PgradC(k,l,j) = PgradC(k,l,j)+aux
9864              enddo ! l
9865            enddo ! k
9866            ELSE
9867            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9868            do k=1,nsaxs
9869              dk = distsaxs(k)
9870 c             write (2,*) "ijk",i,j,k
9871              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9872              if (sss2.eq.0.0d0) cycle
9873              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9874              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9875              Pcalc(k) = Pcalc(k)+expCACA
9876 #ifdef DEBUG
9877              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9878 #endif
9879              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9880      &             ssgrad2*expCACA/sss2
9881              do l=1,3
9882 c CA CA
9883                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9884                PgradC(k,l,i) = PgradC(k,l,i)+aux
9885                PgradC(k,l,j) = PgradC(k,l,j)-aux
9886              enddo ! l
9887            enddo ! k
9888            ENDIF
9889 #endif
9890          enddo ! j
9891        enddo ! iint
9892       enddo ! i
9893 #ifdef MPI
9894       if (nfgtasks.gt.1) then
9895         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9896      &    MPI_SUM,king,FG_COMM,IERR)
9897         if (fg_rank.eq.king) then
9898           do k=1,nsaxs
9899             Pcalc(k) = Pcalc_(k)
9900           enddo
9901         endif
9902         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9903      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9904         if (fg_rank.eq.king) then
9905           do i=1,nres
9906             do l=1,3
9907               do k=1,nsaxs
9908                 PgradC(k,l,i) = PgradC_(k,l,i)
9909               enddo
9910             enddo
9911           enddo
9912         endif
9913 #ifdef ALLSAXS
9914         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9915      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9916         if (fg_rank.eq.king) then
9917           do i=1,nres
9918             do l=1,3
9919               do k=1,nsaxs
9920                 PgradX(k,l,i) = PgradX_(k,l,i)
9921               enddo
9922             enddo
9923           enddo
9924         endif
9925 #endif
9926       endif
9927 #endif
9928 #ifdef MPI
9929       if (fg_rank.eq.king) then
9930 #endif
9931       Cnorm = 0.0d0
9932       do k=1,nsaxs
9933         Cnorm = Cnorm + Pcalc(k)
9934       enddo
9935       Esaxs_constr = dlog(Cnorm)-wsaxs0
9936       do k=1,nsaxs
9937         if (Pcalc(k).gt.0.0d0)
9938      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9939 #ifdef DEBUG
9940         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9941 #endif
9942       enddo
9943 #ifdef DEBUG
9944       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9945 #endif
9946       do i=nnt,nct
9947         do l=1,3
9948           auxC=0.0d0
9949           auxC1=0.0d0
9950           auxX=0.0d0
9951           auxX1=0.d0
9952           do k=1,nsaxs
9953             if (Pcalc(k).gt.0)
9954      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9955             auxC1 = auxC1+PgradC(k,l,i)
9956 #ifdef ALLSAXS
9957             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9958             auxX1 = auxX1+PgradX(k,l,i)
9959 #endif
9960           enddo
9961           gsaxsC(l,i) = auxC - auxC1/Cnorm
9962 #ifdef ALLSAXS
9963           gsaxsX(l,i) = auxX - auxX1/Cnorm
9964 #endif
9965 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9966 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9967         enddo
9968       enddo
9969 #ifdef MPI
9970       endif
9971 #endif
9972       return
9973       end
9974 c----------------------------------------------------------------------------
9975       subroutine e_saxsC(Esaxs_constr)
9976       implicit none
9977       include 'DIMENSIONS'
9978 #ifdef MPI
9979       include "mpif.h"
9980       include "COMMON.SETUP"
9981       integer IERR
9982 #endif
9983       include 'COMMON.SBRIDGE'
9984       include 'COMMON.CHAIN'
9985       include 'COMMON.GEO'
9986       include 'COMMON.LOCAL'
9987       include 'COMMON.INTERACT'
9988       include 'COMMON.VAR'
9989       include 'COMMON.IOUNITS'
9990       include 'COMMON.DERIV'
9991       include 'COMMON.CONTROL'
9992       include 'COMMON.NAMES'
9993       include 'COMMON.FFIELD'
9994       include 'COMMON.LANGEVIN'
9995       include 'COMMON.SAXS'
9996 c
9997       double precision Esaxs_constr
9998       integer i,iint,j,k,l
9999       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
10000 #ifdef MPI
10001       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10002 #endif
10003       double precision dk,dijCASPH,dijSCSPH,
10004      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10005      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10006      & auxX,auxX1,Cnorm
10007 c  SAXS restraint penalty function
10008 #ifdef DEBUG
10009       write(iout,*) "------- SAXS penalty function start -------"
10010       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10011      & " isaxs_end",isaxs_end
10012       write (iout,*) "nnt",nnt," ntc",nct
10013       do i=nnt,nct
10014         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10015      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10016       enddo
10017       do i=nnt,nct
10018         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10019       enddo
10020 #endif
10021       Esaxs_constr = 0.0d0
10022       logPtot=0.0d0
10023       do j=isaxs_start,isaxs_end
10024         Pcalc_=0.0d0
10025         do i=1,nres
10026           do l=1,3
10027             PgradC(l,i)=0.0d0
10028             PgradX(l,i)=0.0d0
10029           enddo
10030         enddo
10031         do i=nnt,nct
10032           dijCASPH=0.0d0
10033           dijSCSPH=0.0d0
10034           do l=1,3
10035             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10036           enddo
10037           if (itype(i).ne.10) then
10038           do l=1,3
10039             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10040           enddo
10041           endif
10042           sigma2CA=2.0d0/pstok**2
10043           sigma2SC=4.0d0/restok(itype(i))**2
10044           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10045           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10046           Pcalc_ = Pcalc_+expCASPH+expSCSPH
10047 #ifdef DEBUG
10048           write(*,*) "processor i j Pcalc",
10049      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
10050 #endif
10051           CASPHgrad = sigma2CA*expCASPH
10052           SCSPHgrad = sigma2SC*expSCSPH
10053           do l=1,3
10054             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10055             PgradX(l,i) = PgradX(l,i) + aux
10056             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10057           enddo ! l
10058         enddo ! i
10059         do i=nnt,nct
10060           do l=1,3
10061             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
10062             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
10063           enddo
10064         enddo
10065         logPtot = logPtot - dlog(Pcalc_)
10066 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
10067 c     &    " logPtot",logPtot
10068       enddo ! j
10069 #ifdef MPI
10070       if (nfgtasks.gt.1) then
10071 c        write (iout,*) "logPtot before reduction",logPtot
10072         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10073      &    MPI_SUM,king,FG_COMM,IERR)
10074         logPtot = logPtot_
10075 c        write (iout,*) "logPtot after reduction",logPtot
10076         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10077      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10078         if (fg_rank.eq.king) then
10079           do i=1,nres
10080             do l=1,3
10081               gsaxsC(l,i) = gsaxsC_(l,i)
10082             enddo
10083           enddo
10084         endif
10085         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10086      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10087         if (fg_rank.eq.king) then
10088           do i=1,nres
10089             do l=1,3
10090               gsaxsX(l,i) = gsaxsX_(l,i)
10091             enddo
10092           enddo
10093         endif
10094       endif
10095 #endif
10096       Esaxs_constr = logPtot
10097       return
10098       end
10099 C--------------------------------------------------------------------------
10100 c MODELLER restraint function
10101       subroutine e_modeller(ehomology_constr)
10102       implicit real*8 (a-h,o-z)
10103       include 'DIMENSIONS'
10104       integer nnn, i, j, k, ki, irec, l
10105       integer katy, odleglosci, test7
10106       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
10107       real*8 distance(max_template),distancek(max_template),
10108      &    min_odl,godl(max_template),dih_diff(max_template)
10109
10110 c
10111 c     FP - 30/10/2014 Temporary specifications for homology restraints
10112 c
10113       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
10114      &                 sgtheta
10115       double precision, dimension (maxres) :: guscdiff,usc_diff
10116       double precision, dimension (max_template) ::
10117      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
10118      &           theta_diff
10119
10120       include 'COMMON.SBRIDGE'
10121       include 'COMMON.CHAIN'
10122       include 'COMMON.GEO'
10123       include 'COMMON.DERIV'
10124       include 'COMMON.LOCAL'
10125       include 'COMMON.INTERACT'
10126       include 'COMMON.VAR'
10127       include 'COMMON.IOUNITS'
10128       include 'COMMON.CONTROL'
10129       include 'COMMON.HOMRESTR'
10130       include 'COMMON.HOMOLOGY'
10131       include 'COMMON.SETUP'
10132       include 'COMMON.NAMES'
10133
10134       do i=1,max_template
10135         distancek(i)=9999999.9
10136       enddo
10137
10138       odleg=0.0d0
10139
10140 c Pseudo-energy and gradient from homology restraints (MODELLER-like
10141 c function)
10142 C AL 5/2/14 - Introduce list of restraints
10143 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
10144 #ifdef DEBUG
10145       write(iout,*) "------- dist restrs start -------"
10146 #endif
10147       do ii = link_start_homo,link_end_homo
10148          i = ires_homo(ii)
10149          j = jres_homo(ii)
10150          dij=dist(i,j)
10151 c        write (iout,*) "dij(",i,j,") =",dij
10152          nexl=0
10153          do k=1,constr_homology
10154            if(.not.l_homo(k,ii)) then
10155               nexl=nexl+1
10156               cycle
10157            endif
10158            distance(k)=odl(k,ii)-dij
10159 c          write (iout,*) "distance(",k,") =",distance(k)
10160 c
10161 c          For Gaussian-type Urestr
10162 c
10163            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
10164 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
10165 c          write (iout,*) "distancek(",k,") =",distancek(k)
10166 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
10167 c
10168 c          For Lorentzian-type Urestr
10169 c
10170            if (waga_dist.lt.0.0d0) then
10171               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10172               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10173      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10174            endif
10175          enddo
10176
10177 c         min_odl=minval(distancek)
10178          do kk=1,constr_homology
10179           if(l_homo(kk,ii)) then
10180             min_odl=distancek(kk)
10181             exit
10182           endif
10183          enddo
10184          do kk=1,constr_homology
10185           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10186      &              min_odl=distancek(kk)
10187          enddo
10188 c        write (iout,* )"min_odl",min_odl
10189 #ifdef DEBUG
10190          write (iout,*) "ij dij",i,j,dij
10191          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10192          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10193          write (iout,* )"min_odl",min_odl
10194 #endif
10195 #ifdef OLDRESTR
10196          odleg2=0.0d0
10197 #else
10198          if (waga_dist.ge.0.0d0) then
10199            odleg2=nexl
10200          else
10201            odleg2=0.0d0
10202          endif
10203 #endif
10204          do k=1,constr_homology
10205 c Nie wiem po co to liczycie jeszcze raz!
10206 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10207 c     &              (2*(sigma_odl(i,j,k))**2))
10208            if(.not.l_homo(k,ii)) cycle
10209            if (waga_dist.ge.0.0d0) then
10210 c
10211 c          For Gaussian-type Urestr
10212 c
10213             godl(k)=dexp(-distancek(k)+min_odl)
10214             odleg2=odleg2+godl(k)
10215 c
10216 c          For Lorentzian-type Urestr
10217 c
10218            else
10219             odleg2=odleg2+distancek(k)
10220            endif
10221
10222 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10223 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10224 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10225 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10226
10227          enddo
10228 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10229 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10230 #ifdef DEBUG
10231          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10232          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10233 #endif
10234            if (waga_dist.ge.0.0d0) then
10235 c
10236 c          For Gaussian-type Urestr
10237 c
10238               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10239 c
10240 c          For Lorentzian-type Urestr
10241 c
10242            else
10243               odleg=odleg+odleg2/constr_homology
10244            endif
10245 c
10246 #ifdef GRAD
10247 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10248 c Gradient
10249 c
10250 c          For Gaussian-type Urestr
10251 c
10252          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10253          sum_sgodl=0.0d0
10254          do k=1,constr_homology
10255 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10256 c     &           *waga_dist)+min_odl
10257 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10258 c
10259          if(.not.l_homo(k,ii)) cycle
10260          if (waga_dist.ge.0.0d0) then
10261 c          For Gaussian-type Urestr
10262 c
10263            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10264 c
10265 c          For Lorentzian-type Urestr
10266 c
10267          else
10268            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10269      &           sigma_odlir(k,ii)**2)**2)
10270          endif
10271            sum_sgodl=sum_sgodl+sgodl
10272
10273 c            sgodl2=sgodl2+sgodl
10274 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10275 c      write(iout,*) "constr_homology=",constr_homology
10276 c      write(iout,*) i, j, k, "TEST K"
10277          enddo
10278          if (waga_dist.ge.0.0d0) then
10279 c
10280 c          For Gaussian-type Urestr
10281 c
10282             grad_odl3=waga_homology(iset)*waga_dist
10283      &                *sum_sgodl/(sum_godl*dij)
10284 c
10285 c          For Lorentzian-type Urestr
10286 c
10287          else
10288 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10289 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10290             grad_odl3=-waga_homology(iset)*waga_dist*
10291      &                sum_sgodl/(constr_homology*dij)
10292          endif
10293 c
10294 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10295
10296
10297 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10298 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10299 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10300
10301 ccc      write(iout,*) godl, sgodl, grad_odl3
10302
10303 c          grad_odl=grad_odl+grad_odl3
10304
10305          do jik=1,3
10306             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10307 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10308 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10309 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10310             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10311             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10312 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10313 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10314 c         if (i.eq.25.and.j.eq.27) then
10315 c         write(iout,*) "jik",jik,"i",i,"j",j
10316 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10317 c         write(iout,*) "grad_odl3",grad_odl3
10318 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10319 c         write(iout,*) "ggodl",ggodl
10320 c         write(iout,*) "ghpbc(",jik,i,")",
10321 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10322 c     &                 ghpbc(jik,j)
10323 c         endif
10324          enddo
10325 #endif
10326 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10327 ccc     & dLOG(odleg2),"-odleg=", -odleg
10328
10329       enddo ! ii-loop for dist
10330 #ifdef DEBUG
10331       write(iout,*) "------- dist restrs end -------"
10332 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10333 c    &     waga_d.eq.1.0d0) call sum_gradient
10334 #endif
10335 c Pseudo-energy and gradient from dihedral-angle restraints from
10336 c homology templates
10337 c      write (iout,*) "End of distance loop"
10338 c      call flush(iout)
10339       kat=0.0d0
10340 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10341 #ifdef DEBUG
10342       write(iout,*) "------- dih restrs start -------"
10343       do i=idihconstr_start_homo,idihconstr_end_homo
10344         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10345       enddo
10346 #endif
10347       do i=idihconstr_start_homo,idihconstr_end_homo
10348         kat2=0.0d0
10349 c        betai=beta(i,i+1,i+2,i+3)
10350         betai = phi(i)
10351 c       write (iout,*) "betai =",betai
10352         do k=1,constr_homology
10353           dih_diff(k)=pinorm(dih(k,i)-betai)
10354 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10355 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10356 c     &                                   -(6.28318-dih_diff(i,k))
10357 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10358 c     &                                   6.28318+dih_diff(i,k)
10359 #ifdef OLD_DIHED
10360           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10361 #else
10362           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10363 #endif
10364 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10365           gdih(k)=dexp(kat3)
10366           kat2=kat2+gdih(k)
10367 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10368 c          write(*,*)""
10369         enddo
10370 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10371 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10372 #ifdef DEBUG
10373         write (iout,*) "i",i," betai",betai," kat2",kat2
10374         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10375 #endif
10376         if (kat2.le.1.0d-14) cycle
10377         kat=kat-dLOG(kat2/constr_homology)
10378 c       write (iout,*) "kat",kat ! sum of -ln-s
10379
10380 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10381 ccc     & dLOG(kat2), "-kat=", -kat
10382
10383 #ifdef GRAD
10384 c ----------------------------------------------------------------------
10385 c Gradient
10386 c ----------------------------------------------------------------------
10387
10388         sum_gdih=kat2
10389         sum_sgdih=0.0d0
10390         do k=1,constr_homology
10391 #ifdef OLD_DIHED
10392           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10393 #else
10394           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10395 #endif
10396 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10397           sum_sgdih=sum_sgdih+sgdih
10398         enddo
10399 c       grad_dih3=sum_sgdih/sum_gdih
10400         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10401
10402 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10403 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10404 ccc     & gloc(nphi+i-3,icg)
10405         gloc(i,icg)=gloc(i,icg)+grad_dih3
10406 c        if (i.eq.25) then
10407 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10408 c        endif
10409 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10410 ccc     & gloc(nphi+i-3,icg)
10411 #endif
10412       enddo ! i-loop for dih
10413 #ifdef DEBUG
10414       write(iout,*) "------- dih restrs end -------"
10415 #endif
10416
10417 c Pseudo-energy and gradient for theta angle restraints from
10418 c homology templates
10419 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10420 c adapted
10421
10422 c
10423 c     For constr_homology reference structures (FP)
10424 c
10425 c     Uconst_back_tot=0.0d0
10426       Eval=0.0d0
10427       Erot=0.0d0
10428 c     Econstr_back legacy
10429 #ifdef GRAD
10430       do i=1,nres
10431 c     do i=ithet_start,ithet_end
10432        dutheta(i)=0.0d0
10433 c     enddo
10434 c     do i=loc_start,loc_end
10435         do j=1,3
10436           duscdiff(j,i)=0.0d0
10437           duscdiffx(j,i)=0.0d0
10438         enddo
10439       enddo
10440 #endif
10441 c
10442 c     do iref=1,nref
10443 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10444 c     write (iout,*) "waga_theta",waga_theta
10445       if (waga_theta.gt.0.0d0) then
10446 #ifdef DEBUG
10447       write (iout,*) "usampl",usampl
10448       write(iout,*) "------- theta restrs start -------"
10449 c     do i=ithet_start,ithet_end
10450 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10451 c     enddo
10452 #endif
10453 c     write (iout,*) "maxres",maxres,"nres",nres
10454
10455       do i=ithet_start,ithet_end
10456 c
10457 c     do i=1,nfrag_back
10458 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10459 c
10460 c Deviation of theta angles wrt constr_homology ref structures
10461 c
10462         utheta_i=0.0d0 ! argument of Gaussian for single k
10463         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10464 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10465 c       over residues in a fragment
10466 c       write (iout,*) "theta(",i,")=",theta(i)
10467         do k=1,constr_homology
10468 c
10469 c         dtheta_i=theta(j)-thetaref(j,iref)
10470 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10471           theta_diff(k)=thetatpl(k,i)-theta(i)
10472 c
10473           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10474 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10475           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10476           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10477 c         Gradient for single Gaussian restraint in subr Econstr_back
10478 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10479 c
10480         enddo
10481 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10482 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10483
10484 c
10485 #ifdef GRAD
10486 c         Gradient for multiple Gaussian restraint
10487         sum_gtheta=gutheta_i
10488         sum_sgtheta=0.0d0
10489         do k=1,constr_homology
10490 c        New generalized expr for multiple Gaussian from Econstr_back
10491          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10492 c
10493 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10494           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10495         enddo
10496 c
10497 c       Final value of gradient using same var as in Econstr_back
10498         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10499      &               *waga_homology(iset)
10500 c       dutheta(i)=sum_sgtheta/sum_gtheta
10501 c
10502 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10503 #endif
10504         Eval=Eval-dLOG(gutheta_i/constr_homology)
10505 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10506 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10507 c       Uconst_back=Uconst_back+utheta(i)
10508       enddo ! (i-loop for theta)
10509 #ifdef DEBUG
10510       write(iout,*) "------- theta restrs end -------"
10511 #endif
10512       endif
10513 c
10514 c Deviation of local SC geometry
10515 c
10516 c Separation of two i-loops (instructed by AL - 11/3/2014)
10517 c
10518 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10519 c     write (iout,*) "waga_d",waga_d
10520
10521 #ifdef DEBUG
10522       write(iout,*) "------- SC restrs start -------"
10523       write (iout,*) "Initial duscdiff,duscdiffx"
10524       do i=loc_start,loc_end
10525         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10526      &                 (duscdiffx(jik,i),jik=1,3)
10527       enddo
10528 #endif
10529       do i=loc_start,loc_end
10530         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10531         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10532 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10533 c       write(iout,*) "xxtab, yytab, zztab"
10534 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10535         do k=1,constr_homology
10536 c
10537           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10538 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10539           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10540           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10541 c         write(iout,*) "dxx, dyy, dzz"
10542 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10543 c
10544           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10545 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10546 c         uscdiffk(k)=usc_diff(i)
10547           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10548           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10549 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10550 c     &      xxref(j),yyref(j),zzref(j)
10551         enddo
10552 c
10553 c       Gradient
10554 c
10555 c       Generalized expression for multiple Gaussian acc to that for a single
10556 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10557 c
10558 c       Original implementation
10559 c       sum_guscdiff=guscdiff(i)
10560 c
10561 c       sum_sguscdiff=0.0d0
10562 c       do k=1,constr_homology
10563 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10564 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10565 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10566 c       enddo
10567 c
10568 c       Implementation of new expressions for gradient (Jan. 2015)
10569 c
10570 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10571 #ifdef GRAD
10572         do k=1,constr_homology
10573 c
10574 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10575 c       before. Now the drivatives should be correct
10576 c
10577           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10578 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10579           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10580           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10581 c
10582 c         New implementation
10583 c
10584           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10585      &                 sigma_d(k,i) ! for the grad wrt r'
10586 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10587 c
10588 c
10589 c        New implementation
10590          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10591          do jik=1,3
10592             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10593      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10594      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10595             duscdiff(jik,i)=duscdiff(jik,i)+
10596      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10597      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10598             duscdiffx(jik,i)=duscdiffx(jik,i)+
10599      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10600      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10601 c
10602 #ifdef DEBUG
10603              write(iout,*) "jik",jik,"i",i
10604              write(iout,*) "dxx, dyy, dzz"
10605              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10606              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10607 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10608 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10609 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10610 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10611 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10612 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10613 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10614 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10615 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10616 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10617 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10618 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10619 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10620 c            endif
10621 #endif
10622          enddo
10623         enddo
10624 #endif
10625 c
10626 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10627 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10628 c
10629 c        write (iout,*) i," uscdiff",uscdiff(i)
10630 c
10631 c Put together deviations from local geometry
10632
10633 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10634 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10635         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10636 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10637 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10638 c       Uconst_back=Uconst_back+usc_diff(i)
10639 c
10640 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10641 c
10642 c     New implment: multiplied by sum_sguscdiff
10643 c
10644
10645       enddo ! (i-loop for dscdiff)
10646
10647 c      endif
10648
10649 #ifdef DEBUG
10650       write(iout,*) "------- SC restrs end -------"
10651         write (iout,*) "------ After SC loop in e_modeller ------"
10652         do i=loc_start,loc_end
10653          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10654          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10655         enddo
10656       if (waga_theta.eq.1.0d0) then
10657       write (iout,*) "in e_modeller after SC restr end: dutheta"
10658       do i=ithet_start,ithet_end
10659         write (iout,*) i,dutheta(i)
10660       enddo
10661       endif
10662       if (waga_d.eq.1.0d0) then
10663       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10664       do i=1,nres
10665         write (iout,*) i,(duscdiff(j,i),j=1,3)
10666         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10667       enddo
10668       endif
10669 #endif
10670
10671 c Total energy from homology restraints
10672 #ifdef DEBUG
10673       write (iout,*) "odleg",odleg," kat",kat
10674       write (iout,*) "odleg",odleg," kat",kat
10675       write (iout,*) "Eval",Eval," Erot",Erot
10676       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10677       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10678       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10679 #endif
10680 c
10681 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10682 c
10683 c     ehomology_constr=odleg+kat
10684 c
10685 c     For Lorentzian-type Urestr
10686 c
10687
10688       if (waga_dist.ge.0.0d0) then
10689 c
10690 c          For Gaussian-type Urestr
10691 c
10692 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10693 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10694         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10695      &              waga_theta*Eval+waga_d*Erot
10696 c     write (iout,*) "ehomology_constr=",ehomology_constr
10697       else
10698 c
10699 c          For Lorentzian-type Urestr
10700 c
10701 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10702 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10703         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10704      &              waga_theta*Eval+waga_d*Erot
10705 c     write (iout,*) "ehomology_constr=",ehomology_constr
10706       endif
10707 #ifdef DEBUG
10708       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10709      & "Eval",waga_theta,eval,
10710      &   "Erot",waga_d,Erot
10711       write (iout,*) "ehomology_constr",ehomology_constr
10712 #endif
10713       return
10714
10715   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10716   747 format(a12,i4,i4,i4,f8.3,f8.3)
10717   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10718   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10719   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10720      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10721       end