source/cluster/wham/src-HCD-5D/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4
   5 #ifndef ISNAN
   6       external proc_proc
   7 #endif
   8 #ifdef WINPGI
   9 cMS$ATTRIBUTES C ::  proc_proc
  10 #endif
  11
  12       include 'COMMON.IOUNITS'
  13       double precision energia(0:max_ene),energia1(0:max_ene+1)
  14       include 'COMMON.FFIELD'
  15       include 'COMMON.DERIV'
  16       include 'COMMON.INTERACT'
  17       include 'COMMON.SBRIDGE'
  18       include 'COMMON.CHAIN'
  19       include 'COMMON.SHIELD'
  20       include 'COMMON.CONTROL'
  21       include 'COMMON.TORCNSTR'
  22       include 'COMMON.SAXS'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C
  47 C Calculate electrostatic (H-bonding) energy of the main chain.
  48 C
  49   106 continue
  50 c      write (iout,*) "Sidechain"
  51       call flush(iout)
  52       call vec_and_deriv
  53       if (shield_mode.eq.1) then
  54        call set_shield_fac
  55       else if  (shield_mode.eq.2) then
  56        call set_shield_fac2
  57       endif
  58       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  59 c            write(iout,*) 'po eelec'
  60 c      call flush(iout)
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       if (wang.gt.0d0) then
  83        if (tor_mode.eq.0) then
  84          call ebend(ebe)
  85        else
  86 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  87 C energy function
  88          call ebend_kcc(ebe)
  89        endif
  90       else
  91         ebe=0.0d0
  92       endif
  93       ethetacnstr=0.0d0
  94       if (with_theta_constr) call etheta_constr(ethetacnstr)
  95 c      call ebend(ebe,ethetacnstr)
  96 cd    print *,'Bend energy finished.'
  97 C
  98 C Calculate the SC local energy.
  99 C
 100       call esc(escloc)
 101 C       print *,'SCLOC energy finished.'
 102 C
 103 C Calculate the virtual-bond torsional energy.
 104 C
 105       if (wtor.gt.0.0d0) then
 106          if (tor_mode.eq.0) then
 107            call etor(etors,fact(1))
 108          else
 109 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 110 C energy function
 111            call etor_kcc(etors,fact(1))
 112          endif
 113       else
 114         etors=0.0d0
 115       endif
 116       edihcnstr=0.0d0
 117       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 118 c      print *,"Processor",myrank," computed Utor"
 119 C
 120 C 6/23/01 Calculate double-torsional energy
 121 C
 122       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 123         call etor_d(etors_d,fact(2))
 124       else
 125         etors_d=0
 126       endif
 127 c      print *,"Processor",myrank," computed Utord"
 128 C
 129       if (wsccor.gt.0.0d0) then
 130         call eback_sc_corr(esccor)
 131       else
 132         esccor=0.0d0
 133       endif
 134
 135       if (wliptran.gt.0) then
 136         call Eliptransfer(eliptran)
 137       else
 138         eliptran=0.0d0
 139       endif
 140 #ifdef FOURBODY
 141 C
 142 C 12/1/95 Multi-body terms
 143 C
 144       n_corr=0
 145       n_corr1=0
 146       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 147      &    .or. wturn6.gt.0.0d0) then
 148 c         write(iout,*)"calling multibody_eello"
 149          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 150 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 151 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 152       else
 153          ecorr=0.0d0
 154          ecorr5=0.0d0
 155          ecorr6=0.0d0
 156          eturn6=0.0d0
 157       endif
 158       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 159 c         write (iout,*) "Calling multibody_hbond"
 160          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 161       endif
 162 #endif
 163 c      write (iout,*) "NSAXS",nsaxs
 164       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 165         call e_saxs(Esaxs_constr)
 166 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 167       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 168         call e_saxsC(Esaxs_constr)
 169 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 170       else
 171         Esaxs_constr = 0.0d0
 172       endif
 173 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 174       if (constr_homology.ge.1) then
 175         call e_modeller(ehomology_constr)
 176       else
 177         ehomology_constr=0.0d0
 178       endif
 179
 180 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 181 #ifdef DFA
 182 C     BARTEK for dfa test!
 183       if (wdfa_dist.gt.0) call edfad(edfadis)
 184 c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
 185       if (wdfa_tor.gt.0) call edfat(edfator)
 186 c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
 187       if (wdfa_nei.gt.0) call edfan(edfanei)
 188 c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
 189       if (wdfa_beta.gt.0) call edfab(edfabet)
 190 c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
 191 #endif
 192
 193 #ifdef SPLITELE
 194       if (shield_mode.gt.0) then
 195       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 196      & +welec*fact(1)*ees
 197      & +fact(1)*wvdwpp*evdw1
 198      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 199      & +wstrain*ehpb
 200      & +wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 201      & +wcorr6*fact(5)*ecorr6
 202      & +wturn4*fact(3)*eello_turn4
 203      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 204      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 205      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 206      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 207      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 208      & +wdfa_beta*edfabet
 209       else
 210       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 211      & +wvdwpp*evdw1
 212      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 213      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 214      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 215      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 216      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 217      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 218      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 219      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 220      & +wdfa_beta*edfabet
 221       endif
 222 #else
 223       if (shield_mode.gt.0) then
 224       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 225      & +welec*fact(1)*(ees+evdw1)
 226      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 227      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 228      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 229      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 230      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 231      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 232      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 233      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 234      & +wdfa_beta*edfabet
 235       else
 236       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 237      & +welec*fact(1)*(ees+evdw1)
 238      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 239      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 240      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 241      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 242      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 243      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 244      & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr
 245      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 246      & +wdfa_beta*edfabet
 247       endif
 248 #endif
 249       energia(0)=etot
 250       energia(1)=evdw
 251 #ifdef SCP14
 252       energia(2)=evdw2-evdw2_14
 253       energia(17)=evdw2_14
 254 #else
 255       energia(2)=evdw2
 256       energia(17)=0.0d0
 257 #endif
 258 #ifdef SPLITELE
 259       energia(3)=ees
 260       energia(16)=evdw1
 261 #else
 262       energia(3)=ees+evdw1
 263       energia(16)=0.0d0
 264 #endif
 265       energia(4)=ecorr
 266       energia(5)=ecorr5
 267       energia(6)=ecorr6
 268       energia(7)=eel_loc
 269       energia(8)=eello_turn3
 270       energia(9)=eello_turn4
 271       energia(10)=eturn6
 272       energia(11)=ebe
 273       energia(12)=escloc
 274       energia(13)=etors
 275       energia(14)=etors_d
 276       energia(15)=ehpb
 277       energia(18)=estr
 278       energia(19)=esccor
 279       energia(20)=edihcnstr
 280       energia(21)=evdw_t
 281       energia(22)=eliptran
 282       energia(24)=ethetacnstr
 283       energia(26)=esaxs_constr
 284       energia(27)=ehomology_constr
 285       energia(28)=edfadis
 286       energia(29)=edfator
 287       energia(30)=edfanei
 288       energia(31)=edfabet
 289 c detecting NaNQ
 290 #ifdef ISNAN
 291 #ifdef AIX
 292       if (isnan(etot).ne.0) energia(0)=1.0d+99
 293 #else
 294       if (isnan(etot)) energia(0)=1.0d+99
 295 #endif
 296 #else
 297       i=0
 298 #ifdef WINPGI
 299       idumm=proc_proc(etot,i)
 300 #else
 301       call proc_proc(etot,i)
 302 #endif
 303       if(i.eq.1)energia(0)=1.0d+99
 304 #endif
 305 #ifdef MPL
 306 c     endif
 307 #endif
 308 #ifdef DEBUG
 309       call enerprint(energia,fact)
 310 #endif
 311       if (calc_grad) then
 312 C
 313 C Sum up the components of the Cartesian gradient.
 314 C
 315 #ifdef SPLITELE
 316       do i=1,nct
 317         do j=1,3
 318       if (shield_mode.eq.0) then
 319           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 320      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 321      &                wbond*gradb(j,i)+
 322      &                wstrain*ghpbc(j,i)+
 323      &                wcorr*fact(3)*gradcorr(j,i)+
 324      &                wel_loc*fact(2)*gel_loc(j,i)+
 325      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 326      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 327      &                wcorr5*fact(4)*gradcorr5(j,i)+
 328      &                wcorr6*fact(5)*gradcorr6(j,i)+
 329      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 330      &                wsccor*fact(2)*gsccorc(j,i)
 331      &               +wliptran*gliptranc(j,i)+
 332      &                wdfa_dist*gdfad(j,i)+
 333      &                wdfa_tor*gdfat(j,i)+
 334      &                wdfa_nei*gdfan(j,i)+
 335      &                wdfa_beta*gdfab(j,i)
 336           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 337      &                  wbond*gradbx(j,i)+
 338      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 339      &                  wsccor*fact(2)*gsccorx(j,i)
 340      &                 +wliptran*gliptranx(j,i)
 341         else
 342           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 343      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 344      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 345      &                wbond*gradb(j,i)+
 346      &                wstrain*ghpbc(j,i)+
 347      &                wcorr*fact(3)*gradcorr(j,i)+
 348      &                wel_loc*fact(2)*gel_loc(j,i)+
 349      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 350      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 351      &                wcorr5*fact(4)*gradcorr5(j,i)+
 352      &                wcorr6*fact(5)*gradcorr6(j,i)+
 353      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 354      &                wsccor*fact(2)*gsccorc(j,i)
 355      &               +wliptran*gliptranc(j,i)
 356      &                 +welec*gshieldc(j,i)
 357      &                 +welec*gshieldc_loc(j,i)
 358      &                 +wcorr*gshieldc_ec(j,i)
 359      &                 +wcorr*gshieldc_loc_ec(j,i)
 360      &                 +wturn3*gshieldc_t3(j,i)
 361      &                 +wturn3*gshieldc_loc_t3(j,i)
 362      &                 +wturn4*gshieldc_t4(j,i)
 363      &                 +wturn4*gshieldc_loc_t4(j,i)
 364      &                 +wel_loc*gshieldc_ll(j,i)
 365      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 366      &                wdfa_dist*gdfad(j,i)+
 367      &                wdfa_tor*gdfat(j,i)+
 368      &                wdfa_nei*gdfan(j,i)+
 369      &                wdfa_beta*gdfab(j,i)
 370           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 371      &                 +fact(1)*wscp*gradx_scp(j,i)+
 372      &                  wbond*gradbx(j,i)+
 373      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 374      &                  wsccor*fact(2)*gsccorx(j,i)
 375      &                 +wliptran*gliptranx(j,i)
 376      &                 +welec*gshieldx(j,i)
 377      &                 +wcorr*gshieldx_ec(j,i)
 378      &                 +wturn3*gshieldx_t3(j,i)
 379      &                 +wturn4*gshieldx_t4(j,i)
 380      &                 +wel_loc*gshieldx_ll(j,i)
 381
 382
 383         endif
 384         enddo
 385 #else
 386       do i=1,nct
 387         do j=1,3
 388                 if (shield_mode.eq.0) then
 389           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 390      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 391      &                wbond*gradb(j,i)+
 392      &                wcorr*fact(3)*gradcorr(j,i)+
 393      &                wel_loc*fact(2)*gel_loc(j,i)+
 394      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 395      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 396      &                wcorr5*fact(4)*gradcorr5(j,i)+
 397      &                wcorr6*fact(5)*gradcorr6(j,i)+
 398      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 399      &                wsccor*fact(2)*gsccorc(j,i)
 400      &               +wliptran*gliptranc(j,i)+
 401      &                wdfa_dist*gdfad(j,i)+
 402      &                wdfa_tor*gdfat(j,i)+
 403      &                wdfa_nei*gdfan(j,i)+
 404      &                wdfa_beta*gdfab(j,i)
 405           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 406      &                  wbond*gradbx(j,i)+
 407      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 408      &                  wsccor*fact(1)*gsccorx(j,i)
 409      &                 +wliptran*gliptranx(j,i)
 410               else
 411           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 412      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 413      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 414      &                wbond*gradb(j,i)+
 415      &                wcorr*fact(3)*gradcorr(j,i)+
 416      &                wel_loc*fact(2)*gel_loc(j,i)+
 417      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 418      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 419      &                wcorr5*fact(4)*gradcorr5(j,i)+
 420      &                wcorr6*fact(5)*gradcorr6(j,i)+
 421      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 422      &                wsccor*fact(2)*gsccorc(j,i)
 423      &               +wliptran*gliptranc(j,i)
 424      &                 +welec*gshieldc(j,i)
 425      &                 +welec*gshieldc_loc(j,i)
 426      &                 +wcorr*gshieldc_ec(j,i)
 427      &                 +wcorr*gshieldc_loc_ec(j,i)
 428      &                 +wturn3*gshieldc_t3(j,i)
 429      &                 +wturn3*gshieldc_loc_t3(j,i)
 430      &                 +wturn4*gshieldc_t4(j,i)
 431      &                 +wturn4*gshieldc_loc_t4(j,i)
 432      &                 +wel_loc*gshieldc_ll(j,i)
 433      &                 +wel_loc*gshieldc_loc_ll(j,i)+
 434      &                wdfa_dist*gdfad(j,i)+
 435      &                wdfa_tor*gdfat(j,i)+
 436      &                wdfa_nei*gdfan(j,i)+
 437      &                wdfa_beta*gdfab(j,i)
 438           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 439      &                  fact(1)*wscp*gradx_scp(j,i)+
 440      &                  wbond*gradbx(j,i)+
 441      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 442      &                  wsccor*fact(1)*gsccorx(j,i)
 443      &                 +wliptran*gliptranx(j,i)
 444      &                 +welec*gshieldx(j,i)
 445      &                 +wcorr*gshieldx_ec(j,i)
 446      &                 +wturn3*gshieldx_t3(j,i)
 447      &                 +wturn4*gshieldx_t4(j,i)
 448      &                 +wel_loc*gshieldx_ll(j,i)
 449          endif
 450         enddo
 451 #endif
 452       enddo
 453
 454
 455       do i=1,nres-3
 456         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 457      &   +wcorr5*fact(4)*g_corr5_loc(i)
 458      &   +wcorr6*fact(5)*g_corr6_loc(i)
 459      &   +wturn4*fact(3)*gel_loc_turn4(i)
 460      &   +wturn3*fact(2)*gel_loc_turn3(i)
 461      &   +wturn6*fact(5)*gel_loc_turn6(i)
 462      &   +wel_loc*fact(2)*gel_loc_loc(i)
 463 c     &   +wsccor*fact(1)*gsccor_loc(i)
 464 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 465       enddo
 466       endif
 467       if (dyn_ss) call dyn_set_nss
 468       return
 469       end
 470 C------------------------------------------------------------------------
 471       subroutine enerprint(energia,fact)
 472       implicit real*8 (a-h,o-z)
 473       include 'DIMENSIONS'
 474       include 'COMMON.IOUNITS'
 475       include 'COMMON.FFIELD'
 476       include 'COMMON.SBRIDGE'
 477       include 'COMMON.CONTROL'
 478       double precision energia(0:max_ene),fact(6)
 479       etot=energia(0)
 480       evdw=energia(1)+fact(6)*energia(21)
 481 #ifdef SCP14
 482       evdw2=energia(2)+energia(17)
 483 #else
 484       evdw2=energia(2)
 485 #endif
 486       ees=energia(3)
 487 #ifdef SPLITELE
 488       evdw1=energia(16)
 489 #endif
 490       ecorr=energia(4)
 491       ecorr5=energia(5)
 492       ecorr6=energia(6)
 493       eel_loc=energia(7)
 494       eello_turn3=energia(8)
 495       eello_turn4=energia(9)
 496       eello_turn6=energia(10)
 497       ebe=energia(11)
 498       escloc=energia(12)
 499       etors=energia(13)
 500       etors_d=energia(14)
 501       ehpb=energia(15)
 502       esccor=energia(19)
 503       edihcnstr=energia(20)
 504       estr=energia(18)
 505       ethetacnstr=energia(24)
 506       eliptran=energia(22)
 507       esaxs=energia(26)
 508       ehomology_constr=energia(27)
 509 C     Bartek
 510       edfadis = energia(28)
 511       edfator = energia(29)
 512       edfanei = energia(30)
 513       edfabet = energia(31)
 514 #ifdef SPLITELE
 515       write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp,
 516      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 517      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 518 #ifdef FOURBODY
 519      &  ecorr,wcorr*fact(3),
 520      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 521 #endif
 522      &  eel_loc,
 523      &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 524      &  eello_turn4,wturn4*fact(3),
 525 #ifdef FOURBODY
 526      &  eello_turn6,wturn6*fact(5),
 527 #endif
 528      &  esccor,wsccor*fact(1),edihcnstr,
 529      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 530      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 531      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 532      &  edfabet,wdfa_beta,
 533      &  etot
 534    10 format (/'Virtual-chain energies:'//
 535      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 536      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 537      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 538      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
 539      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 540      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 541      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 542      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 543      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 544      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 545      & ' (SS bridges & dist. cnstr.)'/
 546 #ifdef FOURBODY
 547      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 548      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 549      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 550 #endif
 551      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 552      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 553      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 554 #ifdef FOURBODY
 555      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 556 #endif
 557      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 558      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 559      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 560      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 561      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 562      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 563      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 564      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 565      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 566      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 567      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 568      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 569      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 570      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 571      & 'ETOT=  ',1pE16.6,' (total)')
 572
 573 #else
 574       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),
 575      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 576      &  etors_d,wtor_d*fact(2),ehpb,
 577 #ifdef FOURBODY
 578      &  wstrain,ecorr,wcorr*fact(3),
 579      &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 580 #endif
 581      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 582      &  eello_turn4,wturn4*fact(3),
 583 #ifdef FOURBODY
 584      &  eello_turn6,wturn6*fact(5),
 585 #endif
 586      &  esccor,wsccor*fact(1),edihcnstr,
 587      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
 588      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
 589      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
 590      &  edfabet,wdfa_beta,
 591      &  etot
 592    10 format (/'Virtual-chain energies:'//
 593      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
 594      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
 595      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
 596      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
 597      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
 598      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
 599      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
 600      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
 601      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
 602      & ' (SS bridges & dist. restr.)'/
 603 #ifdef FOURBODY
 604      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 605      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 606      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
 607 #endif
 608      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
 609      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
 610      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
 611 #ifdef FOURBODY
 612      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
 613 #endif
 614      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
 615      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 616      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 617      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 618      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
 619      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
 620      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
 621      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
 622      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
 623      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 624      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
 625      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
 626      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
 627      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
 628      & 'ETOT=  ',1pE16.6,' (total)')
 629 #endif
 630       return
 631       end
 632 C-----------------------------------------------------------------------
 633       subroutine elj(evdw,evdw_t)
 634 C
 635 C This subroutine calculates the interaction energy of nonbonded side chains
 636 C assuming the LJ potential of interaction.
 637 C
 638       implicit real*8 (a-h,o-z)
 639       include 'DIMENSIONS'
 640       include "DIMENSIONS.COMPAR"
 641       parameter (accur=1.0d-10)
 642       include 'COMMON.GEO'
 643       include 'COMMON.VAR'
 644       include 'COMMON.LOCAL'
 645       include 'COMMON.CHAIN'
 646       include 'COMMON.DERIV'
 647       include 'COMMON.INTERACT'
 648       include 'COMMON.TORSION'
 649       include 'COMMON.SBRIDGE'
 650       include 'COMMON.NAMES'
 651       include 'COMMON.IOUNITS'
 652 #ifdef FOURBODY
 653       include 'COMMON.CONTACTS'
 654       include 'COMMON.CONTMAT'
 655 #endif
 656       dimension gg(3)
 657       integer icant
 658       external icant
 659 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 660 c ROZNICA z cluster
 661 c      do i=1,210
 662 c        do j=1,2
 663 c          eneps_temp(j,i)=0.0d0
 664 c        enddo
 665 c      enddo
 666 cROZNICA
 667
 668       evdw=0.0D0
 669       evdw_t=0.0d0
 670       do i=iatsc_s,iatsc_e
 671         itypi=iabs(itype(i))
 672         if (itypi.eq.ntyp1) cycle
 673         itypi1=iabs(itype(i+1))
 674         xi=c(1,nres+i)
 675         yi=c(2,nres+i)
 676         zi=c(3,nres+i)
 677 C Change 12/1/95
 678         num_conti=0
 679 C
 680 C Calculate SC interaction energy.
 681 C
 682         do iint=1,nint_gr(i)
 683 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 684 cd   &                  'iend=',iend(i,iint)
 685           do j=istart(i,iint),iend(i,iint)
 686             itypj=iabs(itype(j))
 687             if (itypj.eq.ntyp1) cycle
 688             xj=c(1,nres+j)-xi
 689             yj=c(2,nres+j)-yi
 690             zj=c(3,nres+j)-zi
 691 C Change 12/1/95 to calculate four-body interactions
 692             rij=xj*xj+yj*yj+zj*zj
 693             rrij=1.0D0/rij
 694             sqrij=dsqrt(rij)
 695             sss1=sscale(sqrij)
 696             if (sss1.eq.0.0d0) cycle
 697             sssgrad1=sscagrad(sqrij)
 698 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 699             eps0ij=eps(itypi,itypj)
 700             fac=rrij**expon2
 701             e1=fac*fac*aa
 702             e2=fac*bb
 703             evdwij=e1+e2
 704             ij=icant(itypi,itypj)
 705 c ROZNICA z cluster
 706 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 707 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 708 c
 709
 710 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 711 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 712 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 713 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 714 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 715 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 716             if (bb.gt.0.0d0) then
 717               evdw=evdw+sss1*evdwij
 718             else
 719               evdw_t=evdw_t+sss1*evdwij
 720             endif
 721             if (calc_grad) then
 722 C
 723 C Calculate the components of the gradient in DC and X
 724 C
 725             fac=-rrij*(e1+evdwij)*sss1
 726      &          +evdwij*sssgrad1/sqrij/expon
 727             gg(1)=xj*fac
 728             gg(2)=yj*fac
 729             gg(3)=zj*fac
 730             do k=1,3
 731               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 732               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 733             enddo
 734             do k=i,j-1
 735               do l=1,3
 736                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 737               enddo
 738             enddo
 739             endif
 740 #ifdef FOURBODY
 741 C
 742 C 12/1/95, revised on 5/20/97
 743 C
 744 C Calculate the contact function. The ith column of the array JCONT will
 745 C contain the numbers of atoms that make contacts with the atom I (of numbers
 746 C greater than I). The arrays FACONT and GACONT will contain the values of
 747 C the contact function and its derivative.
 748 C
 749 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 750 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 751 C Uncomment next line, if the correlation interactions are contact function only
 752             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 753               rij=dsqrt(rij)
 754               sigij=sigma(itypi,itypj)
 755               r0ij=rs0(itypi,itypj)
 756 C
 757 C Check whether the SC's are not too far to make a contact.
 758 C
 759               rcut=1.5d0*r0ij
 760               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 761 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 762 C
 763               if (fcont.gt.0.0D0) then
 764 C If the SC-SC distance if close to sigma, apply spline.
 765 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 766 cAdam &             fcont1,fprimcont1)
 767 cAdam           fcont1=1.0d0-fcont1
 768 cAdam           if (fcont1.gt.0.0d0) then
 769 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 770 cAdam             fcont=fcont*fcont1
 771 cAdam           endif
 772 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 773 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 774 cga             do k=1,3
 775 cga               gg(k)=gg(k)*eps0ij
 776 cga             enddo
 777 cga             eps0ij=-evdwij*eps0ij
 778 C Uncomment for AL's type of SC correlation interactions.
 779 cadam           eps0ij=-evdwij
 780                 num_conti=num_conti+1
 781                 jcont(num_conti,i)=j
 782                 facont(num_conti,i)=fcont*eps0ij
 783                 fprimcont=eps0ij*fprimcont/rij
 784                 fcont=expon*fcont
 785 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 786 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 787 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 788 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 789                 gacont(1,num_conti,i)=-fprimcont*xj
 790                 gacont(2,num_conti,i)=-fprimcont*yj
 791                 gacont(3,num_conti,i)=-fprimcont*zj
 792 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 793 cd              write (iout,'(2i3,3f10.5)')
 794 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 795               endif
 796             endif
 797 #endif
 798           enddo      ! j
 799         enddo        ! iint
 800 #ifdef FOURBODY
 801 C Change 12/1/95
 802         num_cont(i)=num_conti
 803 #endif
 804       enddo          ! i
 805       if (calc_grad) then
 806       do i=1,nct
 807         do j=1,3
 808           gvdwc(j,i)=expon*gvdwc(j,i)
 809           gvdwx(j,i)=expon*gvdwx(j,i)
 810         enddo
 811       enddo
 812       endif
 813 C******************************************************************************
 814 C
 815 C                              N O T E !!!
 816 C
 817 C To save time, the factor of EXPON has been extracted from ALL components
 818 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 819 C use!
 820 C
 821 C******************************************************************************
 822       return
 823       end
 824 C-----------------------------------------------------------------------------
 825       subroutine eljk(evdw,evdw_t)
 826 C
 827 C This subroutine calculates the interaction energy of nonbonded side chains
 828 C assuming the LJK potential of interaction.
 829 C
 830       implicit real*8 (a-h,o-z)
 831       include 'DIMENSIONS'
 832       include "DIMENSIONS.COMPAR"
 833       include 'COMMON.GEO'
 834       include 'COMMON.VAR'
 835       include 'COMMON.LOCAL'
 836       include 'COMMON.CHAIN'
 837       include 'COMMON.DERIV'
 838       include 'COMMON.INTERACT'
 839       include 'COMMON.IOUNITS'
 840       include 'COMMON.NAMES'
 841       dimension gg(3)
 842       logical scheck
 843       integer icant
 844       external icant
 845 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 846 c      do i=1,210
 847 c        do j=1,2
 848 c          eneps_temp(j,i)=0.0d0
 849 c        enddo
 850 c      enddo
 851       evdw=0.0D0
 852       evdw_t=0.0d0
 853       do i=iatsc_s,iatsc_e
 854         itypi=iabs(itype(i))
 855         if (itypi.eq.ntyp1) cycle
 856         itypi1=iabs(itype(i+1))
 857         xi=c(1,nres+i)
 858         yi=c(2,nres+i)
 859         zi=c(3,nres+i)
 860 C
 861 C Calculate SC interaction energy.
 862 C
 863         do iint=1,nint_gr(i)
 864           do j=istart(i,iint),iend(i,iint)
 865             itypj=iabs(itype(j))
 866             if (itypj.eq.ntyp1) cycle
 867             xj=c(1,nres+j)-xi
 868             yj=c(2,nres+j)-yi
 869             zj=c(3,nres+j)-zi
 870             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 871             fac_augm=rrij**expon
 872             e_augm=augm(itypi,itypj)*fac_augm
 873             r_inv_ij=dsqrt(rrij)
 874             rij=1.0D0/r_inv_ij
 875             sss1=sscale(rij)
 876             if (sss1.eq.0.0d0) cycle
 877             sssgrad1=sscagrad(rij)
 878             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 879             fac=r_shift_inv**expon
 880             e1=fac*fac*aa
 881             e2=fac*bb
 882             evdwij=e_augm+e1+e2
 883             ij=icant(itypi,itypj)
 884 c            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 885 c     &        /dabs(eps(itypi,itypj))
 886 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 887 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 888 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 889 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 890 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 891 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 892 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 893 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 894             if (bb.gt.0.0d0) then
 895               evdw=evdw+evdwij*sss1
 896             else
 897               evdw_t=evdw_t+evdwij*sss1
 898             endif
 899             if (calc_grad) then
 900 C
 901 C Calculate the components of the gradient in DC and X
 902 C
 903            fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1
 904      &          +evdwij*sssgrad1*r_inv_ij/expon
 905             gg(1)=xj*fac
 906             gg(2)=yj*fac
 907             gg(3)=zj*fac
 908             do k=1,3
 909               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 910               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 911             enddo
 912             do k=i,j-1
 913               do l=1,3
 914                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 915               enddo
 916             enddo
 917             endif
 918           enddo      ! j
 919         enddo        ! iint
 920       enddo          ! i
 921       if (calc_grad) then
 922       do i=1,nct
 923         do j=1,3
 924           gvdwc(j,i)=expon*gvdwc(j,i)
 925           gvdwx(j,i)=expon*gvdwx(j,i)
 926         enddo
 927       enddo
 928       endif
 929       return
 930       end
 931 C-----------------------------------------------------------------------------
 932       subroutine ebp(evdw,evdw_t)
 933 C
 934 C This subroutine calculates the interaction energy of nonbonded side chains
 935 C assuming the Berne-Pechukas potential of interaction.
 936 C
 937       implicit real*8 (a-h,o-z)
 938       include 'DIMENSIONS'
 939       include "DIMENSIONS.COMPAR"
 940       include 'COMMON.GEO'
 941       include 'COMMON.VAR'
 942       include 'COMMON.LOCAL'
 943       include 'COMMON.CHAIN'
 944       include 'COMMON.DERIV'
 945       include 'COMMON.NAMES'
 946       include 'COMMON.INTERACT'
 947       include 'COMMON.IOUNITS'
 948       include 'COMMON.CALC'
 949       common /srutu/ icall
 950 c     double precision rrsave(maxdim)
 951       logical lprn
 952       integer icant
 953       external icant
 954 c      do i=1,210
 955 c        do j=1,2
 956 c          eneps_temp(j,i)=0.0d0
 957 c        enddo
 958 c      enddo
 959       evdw=0.0D0
 960       evdw_t=0.0d0
 961 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 962 c     if (icall.eq.0) then
 963 c       lprn=.true.
 964 c     else
 965         lprn=.false.
 966 c     endif
 967       ind=0
 968       do i=iatsc_s,iatsc_e
 969         itypi=iabs(itype(i))
 970         if (itypi.eq.ntyp1) cycle
 971         itypi1=iabs(itype(i+1))
 972         xi=c(1,nres+i)
 973         yi=c(2,nres+i)
 974         zi=c(3,nres+i)
 975         dxi=dc_norm(1,nres+i)
 976         dyi=dc_norm(2,nres+i)
 977         dzi=dc_norm(3,nres+i)
 978         dsci_inv=vbld_inv(i+nres)
 979 C
 980 C Calculate SC interaction energy.
 981 C
 982         do iint=1,nint_gr(i)
 983           do j=istart(i,iint),iend(i,iint)
 984             ind=ind+1
 985             itypj=iabs(itype(j))
 986             if (itypj.eq.ntyp1) cycle
 987             dscj_inv=vbld_inv(j+nres)
 988             chi1=chi(itypi,itypj)
 989             chi2=chi(itypj,itypi)
 990             chi12=chi1*chi2
 991             chip1=chip(itypi)
 992             chip2=chip(itypj)
 993             chip12=chip1*chip2
 994             alf1=alp(itypi)
 995             alf2=alp(itypj)
 996             alf12=0.5D0*(alf1+alf2)
 997 C For diagnostics only!!!
 998 c           chi1=0.0D0
 999 c           chi2=0.0D0
1000 c           chi12=0.0D0
1001 c           chip1=0.0D0
1002 c           chip2=0.0D0
1003 c           chip12=0.0D0
1004 c           alf1=0.0D0
1005 c           alf2=0.0D0
1006 c           alf12=0.0D0
1007             xj=c(1,nres+j)-xi
1008             yj=c(2,nres+j)-yi
1009             zj=c(3,nres+j)-zi
1010             dxj=dc_norm(1,nres+j)
1011             dyj=dc_norm(2,nres+j)
1012             dzj=dc_norm(3,nres+j)
1013             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1014 cd          if (icall.eq.0) then
1015 cd            rrsave(ind)=rrij
1016 cd          else
1017 cd            rrij=rrsave(ind)
1018 cd          endif
1019             rij=dsqrt(rrij)
1020 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1021             call sc_angular
1022 C Calculate whole angle-dependent part of epsilon and contributions
1023 C to its derivatives
1024             fac=(rrij*sigsq)**expon2
1025             e1=fac*fac*aa
1026             e2=fac*bb
1027             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1028             eps2der=evdwij*eps3rt
1029             eps3der=evdwij*eps2rt
1030             evdwij=evdwij*eps2rt*eps3rt
1031             ij=icant(itypi,itypj)
1032             aux=eps1*eps2rt**2*eps3rt**2
1033 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
1034 c     &        /dabs(eps(itypi,itypj))
1035 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
1036             if (bb.gt.0.0d0) then
1037               evdw=evdw+evdwij
1038             else
1039               evdw_t=evdw_t+evdwij
1040             endif
1041             if (calc_grad) then
1042             if (lprn) then
1043             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1044             epsi=bb**2/aa
1045             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1046      &        restyp(itypi),i,restyp(itypj),j,
1047      &        epsi,sigm,chi1,chi2,chip1,chip2,
1048      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1049      &        om1,om2,om12,1.0D0/dsqrt(rrij),
1050      &        evdwij
1051             endif
1052 C Calculate gradient components.
1053             e1=e1*eps1*eps2rt**2*eps3rt**2
1054             fac=-expon*(e1+evdwij)
1055             sigder=fac/sigsq
1056             fac=rrij*fac
1057 C Calculate radial part of the gradient
1058             gg(1)=xj*fac
1059             gg(2)=yj*fac
1060             gg(3)=zj*fac
1061 C Calculate the angular part of the gradient and sum add the contributions
1062 C to the appropriate components of the Cartesian gradient.
1063             call sc_grad
1064             endif
1065           enddo      ! j
1066         enddo        ! iint
1067       enddo          ! i
1068 c     stop
1069       return
1070       end
1071 C-----------------------------------------------------------------------------
1072       subroutine egb(evdw,evdw_t)
1073 C
1074 C This subroutine calculates the interaction energy of nonbonded side chains
1075 C assuming the Gay-Berne potential of interaction.
1076 C
1077       implicit real*8 (a-h,o-z)
1078       include 'DIMENSIONS'
1079       include "DIMENSIONS.COMPAR"
1080       include 'COMMON.GEO'
1081       include 'COMMON.VAR'
1082       include 'COMMON.LOCAL'
1083       include 'COMMON.CHAIN'
1084       include 'COMMON.DERIV'
1085       include 'COMMON.NAMES'
1086       include 'COMMON.INTERACT'
1087       include 'COMMON.IOUNITS'
1088       include 'COMMON.CALC'
1089       include 'COMMON.SBRIDGE'
1090       logical lprn
1091       common /srutu/icall
1092       integer icant,xshift,yshift,zshift
1093       external icant
1094 c      do i=1,210
1095 c        do j=1,2
1096 c          eneps_temp(j,i)=0.0d0
1097 c        enddo
1098 c      enddo
1099 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1100       evdw=0.0D0
1101       evdw_t=0.0d0
1102       lprn=.false.
1103 c      if (icall.gt.0) lprn=.true.
1104       ind=0
1105       do i=iatsc_s,iatsc_e
1106         itypi=iabs(itype(i))
1107         if (itypi.eq.ntyp1) cycle
1108         itypi1=iabs(itype(i+1))
1109         xi=c(1,nres+i)
1110         yi=c(2,nres+i)
1111         zi=c(3,nres+i)
1112 C returning the ith atom to box
1113           xi=mod(xi,boxxsize)
1114           if (xi.lt.0) xi=xi+boxxsize
1115           yi=mod(yi,boxysize)
1116           if (yi.lt.0) yi=yi+boxysize
1117           zi=mod(zi,boxzsize)
1118           if (zi.lt.0) zi=zi+boxzsize
1119        if ((zi.gt.bordlipbot)
1120      &.and.(zi.lt.bordliptop)) then
1121 C the energy transfer exist
1122         if (zi.lt.buflipbot) then
1123 C what fraction I am in
1124          fracinbuf=1.0d0-
1125      &        ((zi-bordlipbot)/lipbufthick)
1126 C lipbufthick is thickenes of lipid buffore
1127          sslipi=sscalelip(fracinbuf)
1128          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1129         elseif (zi.gt.bufliptop) then
1130          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1131          sslipi=sscalelip(fracinbuf)
1132          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1133         else
1134          sslipi=1.0d0
1135          ssgradlipi=0.0
1136         endif
1137        else
1138          sslipi=0.0d0
1139          ssgradlipi=0.0
1140        endif
1141
1142         dxi=dc_norm(1,nres+i)
1143         dyi=dc_norm(2,nres+i)
1144         dzi=dc_norm(3,nres+i)
1145         dsci_inv=vbld_inv(i+nres)
1146 C
1147 C Calculate SC interaction energy.
1148 C
1149         do iint=1,nint_gr(i)
1150           do j=istart(i,iint),iend(i,iint)
1151             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1152               call dyn_ssbond_ene(i,j,evdwij)
1153               evdw=evdw+evdwij
1154 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1155 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1156 C triple bond artifac removal
1157              do k=j+1,iend(i,iint)
1158 C search over all next residues
1159               if (dyn_ss_mask(k)) then
1160 C check if they are cysteins
1161 C              write(iout,*) 'k=',k
1162               call triple_ssbond_ene(i,j,k,evdwij)
1163 C call the energy function that removes the artifical triple disulfide
1164 C bond the soubroutine is located in ssMD.F
1165               evdw=evdw+evdwij
1166 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1167 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1168               endif!dyn_ss_mask(k)
1169              enddo! k
1170             ELSE
1171             ind=ind+1
1172             itypj=iabs(itype(j))
1173             if (itypj.eq.ntyp1) cycle
1174             dscj_inv=vbld_inv(j+nres)
1175             sig0ij=sigma(itypi,itypj)
1176             chi1=chi(itypi,itypj)
1177             chi2=chi(itypj,itypi)
1178             chi12=chi1*chi2
1179             chip1=chip(itypi)
1180             chip2=chip(itypj)
1181             chip12=chip1*chip2
1182             alf1=alp(itypi)
1183             alf2=alp(itypj)
1184             alf12=0.5D0*(alf1+alf2)
1185 C For diagnostics only!!!
1186 c           chi1=0.0D0
1187 c           chi2=0.0D0
1188 c           chi12=0.0D0
1189 c           chip1=0.0D0
1190 c           chip2=0.0D0
1191 c           chip12=0.0D0
1192 c           alf1=0.0D0
1193 c           alf2=0.0D0
1194 c           alf12=0.0D0
1195             xj=c(1,nres+j)
1196             yj=c(2,nres+j)
1197             zj=c(3,nres+j)
1198 C returning jth atom to box
1199           xj=mod(xj,boxxsize)
1200           if (xj.lt.0) xj=xj+boxxsize
1201           yj=mod(yj,boxysize)
1202           if (yj.lt.0) yj=yj+boxysize
1203           zj=mod(zj,boxzsize)
1204           if (zj.lt.0) zj=zj+boxzsize
1205        if ((zj.gt.bordlipbot)
1206      &.and.(zj.lt.bordliptop)) then
1207 C the energy transfer exist
1208         if (zj.lt.buflipbot) then
1209 C what fraction I am in
1210          fracinbuf=1.0d0-
1211      &        ((zj-bordlipbot)/lipbufthick)
1212 C lipbufthick is thickenes of lipid buffore
1213          sslipj=sscalelip(fracinbuf)
1214          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1215         elseif (zj.gt.bufliptop) then
1216          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1217          sslipj=sscalelip(fracinbuf)
1218          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1219         else
1220          sslipj=1.0d0
1221          ssgradlipj=0.0
1222         endif
1223        else
1224          sslipj=0.0d0
1225          ssgradlipj=0.0
1226        endif
1227       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1228      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1229       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1230      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1231 C       if (aa.ne.aa_aq(itypi,itypj)) then
1232
1233 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1234 C     & bb_aq(itypi,itypj)-bb,
1235 C     & sslipi,sslipj
1236 C         endif
1237
1238 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1239 C checking the distance
1240       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1241       xj_safe=xj
1242       yj_safe=yj
1243       zj_safe=zj
1244       subchap=0
1245 C finding the closest
1246       do xshift=-1,1
1247       do yshift=-1,1
1248       do zshift=-1,1
1249           xj=xj_safe+xshift*boxxsize
1250           yj=yj_safe+yshift*boxysize
1251           zj=zj_safe+zshift*boxzsize
1252           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1253           if(dist_temp.lt.dist_init) then
1254             dist_init=dist_temp
1255             xj_temp=xj
1256             yj_temp=yj
1257             zj_temp=zj
1258             subchap=1
1259           endif
1260        enddo
1261        enddo
1262        enddo
1263        if (subchap.eq.1) then
1264           xj=xj_temp-xi
1265           yj=yj_temp-yi
1266           zj=zj_temp-zi
1267        else
1268           xj=xj_safe-xi
1269           yj=yj_safe-yi
1270           zj=zj_safe-zi
1271        endif
1272
1273             dxj=dc_norm(1,nres+j)
1274             dyj=dc_norm(2,nres+j)
1275             dzj=dc_norm(3,nres+j)
1276 c            write (iout,*) i,j,xj,yj,zj
1277             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1278             rij=dsqrt(rrij)
1279             sss=sscale(1.0d0/rij)
1280             sssgrad=sscagrad(1.0d0/rij)
1281             if (sss.le.0.0) cycle
1282 C Calculate angle-dependent terms of energy and contributions to their
1283 C derivatives.
1284
1285             call sc_angular
1286             sigsq=1.0D0/sigsq
1287             sig=sig0ij*dsqrt(sigsq)
1288             rij_shift=1.0D0/rij-sig+sig0ij
1289 C I hate to put IF's in the loops, but here don't have another choice!!!!
1290             if (rij_shift.le.0.0D0) then
1291               evdw=1.0D20
1292               return
1293             endif
1294             sigder=-sig*sigsq
1295 c---------------------------------------------------------------
1296             rij_shift=1.0D0/rij_shift
1297             fac=rij_shift**expon
1298             e1=fac*fac*aa
1299             e2=fac*bb
1300             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1301             eps2der=evdwij*eps3rt
1302             eps3der=evdwij*eps2rt
1303             evdwij=evdwij*eps2rt*eps3rt
1304             if (bb.gt.0) then
1305               evdw=evdw+evdwij*sss
1306             else
1307               evdw_t=evdw_t+evdwij*sss
1308             endif
1309             ij=icant(itypi,itypj)
1310             aux=eps1*eps2rt**2*eps3rt**2
1311 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1312 c     &        /dabs(eps(itypi,itypj))
1313 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1314 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1315 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1316 c     &         aux*e2/eps(itypi,itypj)
1317 c            if (lprn) then
1318             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1319             epsi=bb**2/aa
1320 C#define DEBUG
1321 #ifdef DEBUG
1322             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1323      &        restyp(itypi),i,restyp(itypj),j,
1324      &        epsi,sigm,chi1,chi2,chip1,chip2,
1325      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1326      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1327      &        evdwij
1328              write (iout,*) "partial sum", evdw, evdw_t
1329 #endif
1330 C#undef DEBUG
1331 c            endif
1332             if (calc_grad) then
1333 C Calculate gradient components.
1334             e1=e1*eps1*eps2rt**2*eps3rt**2
1335             fac=-expon*(e1+evdwij)*rij_shift
1336             sigder=fac*sigder
1337             fac=rij*fac
1338             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1339 C Calculate the radial part of the gradient
1340             gg(1)=xj*fac
1341             gg(2)=yj*fac
1342             gg(3)=zj*fac
1343 C Calculate angular part of the gradient.
1344             call sc_grad
1345             endif
1346 C            write(iout,*)  "partial sum", evdw, evdw_t
1347             ENDIF    ! dyn_ss
1348           enddo      ! j
1349         enddo        ! iint
1350       enddo          ! i
1351       return
1352       end
1353 C-----------------------------------------------------------------------------
1354       subroutine egbv(evdw,evdw_t)
1355 C
1356 C This subroutine calculates the interaction energy of nonbonded side chains
1357 C assuming the Gay-Berne-Vorobjev potential of interaction.
1358 C
1359       implicit real*8 (a-h,o-z)
1360       include 'DIMENSIONS'
1361       include "DIMENSIONS.COMPAR"
1362       include 'COMMON.GEO'
1363       include 'COMMON.VAR'
1364       include 'COMMON.LOCAL'
1365       include 'COMMON.CHAIN'
1366       include 'COMMON.DERIV'
1367       include 'COMMON.NAMES'
1368       include 'COMMON.INTERACT'
1369       include 'COMMON.IOUNITS'
1370       include 'COMMON.CALC'
1371       common /srutu/ icall
1372       logical lprn
1373       integer icant
1374       external icant
1375 c      do i=1,210
1376 c        do j=1,2
1377 c          eneps_temp(j,i)=0.0d0
1378 c        enddo
1379 c      enddo
1380       evdw=0.0D0
1381       evdw_t=0.0d0
1382 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1383       evdw=0.0D0
1384       lprn=.false.
1385 c      if (icall.gt.0) lprn=.true.
1386       ind=0
1387       do i=iatsc_s,iatsc_e
1388         itypi=iabs(itype(i))
1389         if (itypi.eq.ntyp1) cycle
1390         itypi1=iabs(itype(i+1))
1391         xi=c(1,nres+i)
1392         yi=c(2,nres+i)
1393         zi=c(3,nres+i)
1394         dxi=dc_norm(1,nres+i)
1395         dyi=dc_norm(2,nres+i)
1396         dzi=dc_norm(3,nres+i)
1397         dsci_inv=vbld_inv(i+nres)
1398 C
1399 C Calculate SC interaction energy.
1400 C
1401         do iint=1,nint_gr(i)
1402           do j=istart(i,iint),iend(i,iint)
1403             ind=ind+1
1404             itypj=iabs(itype(j))
1405             if (itypj.eq.ntyp1) cycle
1406             dscj_inv=vbld_inv(j+nres)
1407             sig0ij=sigma(itypi,itypj)
1408             r0ij=r0(itypi,itypj)
1409             chi1=chi(itypi,itypj)
1410             chi2=chi(itypj,itypi)
1411             chi12=chi1*chi2
1412             chip1=chip(itypi)
1413             chip2=chip(itypj)
1414             chip12=chip1*chip2
1415             alf1=alp(itypi)
1416             alf2=alp(itypj)
1417             alf12=0.5D0*(alf1+alf2)
1418 C For diagnostics only!!!
1419 c           chi1=0.0D0
1420 c           chi2=0.0D0
1421 c           chi12=0.0D0
1422 c           chip1=0.0D0
1423 c           chip2=0.0D0
1424 c           chip12=0.0D0
1425 c           alf1=0.0D0
1426 c           alf2=0.0D0
1427 c           alf12=0.0D0
1428             xj=c(1,nres+j)-xi
1429             yj=c(2,nres+j)-yi
1430             zj=c(3,nres+j)-zi
1431             dxj=dc_norm(1,nres+j)
1432             dyj=dc_norm(2,nres+j)
1433             dzj=dc_norm(3,nres+j)
1434             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1435             rij=dsqrt(rrij)
1436             sss=sscale(1.0d0/rij)
1437             if (sss.eq.0.0d0) cycle
1438             sssgrad=sscagrad(1.0d0/rij)
1439 C Calculate angle-dependent terms of energy and contributions to their
1440 C derivatives.
1441             call sc_angular
1442             sigsq=1.0D0/sigsq
1443             sig=sig0ij*dsqrt(sigsq)
1444             rij_shift=1.0D0/rij-sig+r0ij
1445 C I hate to put IF's in the loops, but here don't have another choice!!!!
1446             if (rij_shift.le.0.0D0) then
1447               evdw=1.0D20
1448               return
1449             endif
1450             sigder=-sig*sigsq
1451 c---------------------------------------------------------------
1452             rij_shift=1.0D0/rij_shift
1453             fac=rij_shift**expon
1454             e1=fac*fac*aa
1455             e2=fac*bb
1456             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1457             eps2der=evdwij*eps3rt
1458             eps3der=evdwij*eps2rt
1459             fac_augm=rrij**expon
1460             e_augm=augm(itypi,itypj)*fac_augm
1461             evdwij=evdwij*eps2rt*eps3rt
1462             if (bb.gt.0.0d0) then
1463               evdw=evdw+(evdwij+e_augm)*sss
1464             else
1465               evdw_t=evdw_t+(evdwij+e_augm)*sss
1466             endif
1467             ij=icant(itypi,itypj)
1468             aux=eps1*eps2rt**2*eps3rt**2
1469 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1470 c     &        /dabs(eps(itypi,itypj))
1471 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1472 c            eneps_temp(ij)=eneps_temp(ij)
1473 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1474 c            if (lprn) then
1475 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1476 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1477 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1478 c     &        restyp(itypi),i,restyp(itypj),j,
1479 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1480 c     &        chi1,chi2,chip1,chip2,
1481 c     &        eps1,eps2rt**2,eps3rt**2,
1482 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1483 c     &        evdwij+e_augm
1484 c            endif
1485             if (calc_grad) then
1486 C Calculate gradient components.
1487             e1=e1*eps1*eps2rt**2*eps3rt**2
1488             fac=-expon*(e1+evdwij)*rij_shift
1489             sigder=fac*sigder
1490             fac=rij*fac-2*expon*rrij*e_augm
1491             fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
1492 C Calculate the radial part of the gradient
1493             gg(1)=xj*fac
1494             gg(2)=yj*fac
1495             gg(3)=zj*fac
1496 C Calculate angular part of the gradient.
1497             call sc_grad
1498             endif
1499           enddo      ! j
1500         enddo        ! iint
1501       enddo          ! i
1502       return
1503       end
1504 C-----------------------------------------------------------------------------
1505       subroutine sc_angular
1506 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1507 C om12. Called by ebp, egb, and egbv.
1508       implicit none
1509       include 'COMMON.CALC'
1510       erij(1)=xj*rij
1511       erij(2)=yj*rij
1512       erij(3)=zj*rij
1513       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1514       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1515       om12=dxi*dxj+dyi*dyj+dzi*dzj
1516       chiom12=chi12*om12
1517 C Calculate eps1(om12) and its derivative in om12
1518       faceps1=1.0D0-om12*chiom12
1519       faceps1_inv=1.0D0/faceps1
1520       eps1=dsqrt(faceps1_inv)
1521 C Following variable is eps1*deps1/dom12
1522       eps1_om12=faceps1_inv*chiom12
1523 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1524 C and om12.
1525       om1om2=om1*om2
1526       chiom1=chi1*om1
1527       chiom2=chi2*om2
1528       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1529       sigsq=1.0D0-facsig*faceps1_inv
1530       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1531       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1532       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1533 C Calculate eps2 and its derivatives in om1, om2, and om12.
1534       chipom1=chip1*om1
1535       chipom2=chip2*om2
1536       chipom12=chip12*om12
1537       facp=1.0D0-om12*chipom12
1538       facp_inv=1.0D0/facp
1539       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1540 C Following variable is the square root of eps2
1541       eps2rt=1.0D0-facp1*facp_inv
1542 C Following three variables are the derivatives of the square root of eps
1543 C in om1, om2, and om12.
1544       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1545       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1546       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1547 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1548       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1549 C Calculate whole angle-dependent part of epsilon and contributions
1550 C to its derivatives
1551       return
1552       end
1553 C----------------------------------------------------------------------------
1554       subroutine sc_grad
1555       implicit real*8 (a-h,o-z)
1556       include 'DIMENSIONS'
1557       include 'COMMON.CHAIN'
1558       include 'COMMON.DERIV'
1559       include 'COMMON.CALC'
1560       double precision dcosom1(3),dcosom2(3)
1561       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1562       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1563       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1564      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1565       do k=1,3
1566         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1567         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1568       enddo
1569       do k=1,3
1570         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1571       enddo
1572       do k=1,3
1573         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1574      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1575      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1576         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1577      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1578      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1579       enddo
1580 C
1581 C Calculate the components of the gradient in DC and X
1582 C
1583       do k=i,j-1
1584         do l=1,3
1585           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1586         enddo
1587       enddo
1588       return
1589       end
1590 c------------------------------------------------------------------------------
1591       subroutine vec_and_deriv
1592       implicit real*8 (a-h,o-z)
1593       include 'DIMENSIONS'
1594       include 'COMMON.IOUNITS'
1595       include 'COMMON.GEO'
1596       include 'COMMON.VAR'
1597       include 'COMMON.LOCAL'
1598       include 'COMMON.CHAIN'
1599       include 'COMMON.VECTORS'
1600       include 'COMMON.DERIV'
1601       include 'COMMON.INTERACT'
1602       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1603 C Compute the local reference systems. For reference system (i), the
1604 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1605 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1606       do i=1,nres-1
1607 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1608           if (i.eq.nres-1) then
1609 C Case of the last full residue
1610 C Compute the Z-axis
1611             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1612             costh=dcos(pi-theta(nres))
1613             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1614 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1615 c     &         " uz",uz(:,i)
1616             do k=1,3
1617               uz(k,i)=fac*uz(k,i)
1618             enddo
1619             if (calc_grad) then
1620 C Compute the derivatives of uz
1621             uzder(1,1,1)= 0.0d0
1622             uzder(2,1,1)=-dc_norm(3,i-1)
1623             uzder(3,1,1)= dc_norm(2,i-1)
1624             uzder(1,2,1)= dc_norm(3,i-1)
1625             uzder(2,2,1)= 0.0d0
1626             uzder(3,2,1)=-dc_norm(1,i-1)
1627             uzder(1,3,1)=-dc_norm(2,i-1)
1628             uzder(2,3,1)= dc_norm(1,i-1)
1629             uzder(3,3,1)= 0.0d0
1630             uzder(1,1,2)= 0.0d0
1631             uzder(2,1,2)= dc_norm(3,i)
1632             uzder(3,1,2)=-dc_norm(2,i)
1633             uzder(1,2,2)=-dc_norm(3,i)
1634             uzder(2,2,2)= 0.0d0
1635             uzder(3,2,2)= dc_norm(1,i)
1636             uzder(1,3,2)= dc_norm(2,i)
1637             uzder(2,3,2)=-dc_norm(1,i)
1638             uzder(3,3,2)= 0.0d0
1639             endif ! calc_grad
1640 C Compute the Y-axis
1641             facy=fac
1642             do k=1,3
1643               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1644             enddo
1645             if (calc_grad) then
1646 C Compute the derivatives of uy
1647             do j=1,3
1648               do k=1,3
1649                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1650      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1651                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1652               enddo
1653               uyder(j,j,1)=uyder(j,j,1)-costh
1654               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1655             enddo
1656             do j=1,2
1657               do k=1,3
1658                 do l=1,3
1659                   uygrad(l,k,j,i)=uyder(l,k,j)
1660                   uzgrad(l,k,j,i)=uzder(l,k,j)
1661                 enddo
1662               enddo
1663             enddo
1664             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1665             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1666             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1667             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1668             endif
1669           else
1670 C Other residues
1671 C Compute the Z-axis
1672             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1673             costh=dcos(pi-theta(i+2))
1674             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1675             do k=1,3
1676               uz(k,i)=fac*uz(k,i)
1677             enddo
1678             if (calc_grad) then
1679 C Compute the derivatives of uz
1680             uzder(1,1,1)= 0.0d0
1681             uzder(2,1,1)=-dc_norm(3,i+1)
1682             uzder(3,1,1)= dc_norm(2,i+1)
1683             uzder(1,2,1)= dc_norm(3,i+1)
1684             uzder(2,2,1)= 0.0d0
1685             uzder(3,2,1)=-dc_norm(1,i+1)
1686             uzder(1,3,1)=-dc_norm(2,i+1)
1687             uzder(2,3,1)= dc_norm(1,i+1)
1688             uzder(3,3,1)= 0.0d0
1689             uzder(1,1,2)= 0.0d0
1690             uzder(2,1,2)= dc_norm(3,i)
1691             uzder(3,1,2)=-dc_norm(2,i)
1692             uzder(1,2,2)=-dc_norm(3,i)
1693             uzder(2,2,2)= 0.0d0
1694             uzder(3,2,2)= dc_norm(1,i)
1695             uzder(1,3,2)= dc_norm(2,i)
1696             uzder(2,3,2)=-dc_norm(1,i)
1697             uzder(3,3,2)= 0.0d0
1698             endif
1699 C Compute the Y-axis
1700             facy=fac
1701             do k=1,3
1702               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1703             enddo
1704             if (calc_grad) then
1705 C Compute the derivatives of uy
1706             do j=1,3
1707               do k=1,3
1708                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1709      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1710                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1711               enddo
1712               uyder(j,j,1)=uyder(j,j,1)-costh
1713               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1714             enddo
1715             do j=1,2
1716               do k=1,3
1717                 do l=1,3
1718                   uygrad(l,k,j,i)=uyder(l,k,j)
1719                   uzgrad(l,k,j,i)=uzder(l,k,j)
1720                 enddo
1721               enddo
1722             enddo
1723             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1724             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1725             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1726             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1727           endif
1728           endif
1729       enddo
1730       if (calc_grad) then
1731       do i=1,nres-1
1732         vbld_inv_temp(1)=vbld_inv(i+1)
1733         if (i.lt.nres-1) then
1734           vbld_inv_temp(2)=vbld_inv(i+2)
1735         else
1736           vbld_inv_temp(2)=vbld_inv(i)
1737         endif
1738         do j=1,2
1739           do k=1,3
1740             do l=1,3
1741               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1742               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1743             enddo
1744           enddo
1745         enddo
1746       enddo
1747       endif
1748       return
1749       end
1750 C--------------------------------------------------------------------------
1751       subroutine set_matrices
1752       implicit real*8 (a-h,o-z)
1753       include 'DIMENSIONS'
1754 #ifdef MPI
1755       include "mpif.h"
1756       integer IERR
1757       integer status(MPI_STATUS_SIZE)
1758 #endif
1759       include 'COMMON.IOUNITS'
1760       include 'COMMON.GEO'
1761       include 'COMMON.VAR'
1762       include 'COMMON.LOCAL'
1763       include 'COMMON.CHAIN'
1764       include 'COMMON.DERIV'
1765       include 'COMMON.INTERACT'
1766       include 'COMMON.CONTACTS'
1767       include 'COMMON.TORSION'
1768       include 'COMMON.VECTORS'
1769       include 'COMMON.FFIELD'
1770       include 'COMMON.CORRMAT'
1771       double precision auxvec(2),auxmat(2,2)
1772 C
1773 C Compute the virtual-bond-torsional-angle dependent quantities needed
1774 C to calculate the el-loc multibody terms of various order.
1775 C
1776 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1777       do i=3,nres+1
1778         ii=ireschain(i-2)
1779         if (ii.eq.0) cycle
1780         innt=chain_border(1,ii)
1781         inct=chain_border(2,ii)
1782         if (i.gt. innt+2 .and. i.lt.inct+2) then
1783           iti = itype2loc(itype(i-2))
1784         else
1785           iti=nloctyp
1786         endif
1787 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1788         if (i.gt. innt+1 .and. i.lt.inct+1) then
1789           iti1 = itype2loc(itype(i-1))
1790         else
1791           iti1=nloctyp
1792         endif
1793 #ifdef NEWCORR
1794         cost1=dcos(theta(i-1))
1795         sint1=dsin(theta(i-1))
1796         sint1sq=sint1*sint1
1797         sint1cub=sint1sq*sint1
1798         sint1cost1=2*sint1*cost1
1799 #ifdef DEBUG
1800         write (iout,*) "bnew1",i,iti
1801         write (iout,*) (bnew1(k,1,iti),k=1,3)
1802         write (iout,*) (bnew1(k,2,iti),k=1,3)
1803         write (iout,*) "bnew2",i,iti
1804         write (iout,*) (bnew2(k,1,iti),k=1,3)
1805         write (iout,*) (bnew2(k,2,iti),k=1,3)
1806 #endif
1807         do k=1,2
1808           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1809           b1(k,i-2)=sint1*b1k
1810           gtb1(k,i-2)=cost1*b1k-sint1sq*
1811      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1812           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1813           b2(k,i-2)=sint1*b2k
1814           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1815      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1816         enddo
1817         do k=1,2
1818           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1819           cc(1,k,i-2)=sint1sq*aux
1820           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1821      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1822           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1823           dd(1,k,i-2)=sint1sq*aux
1824           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1825      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1826         enddo
1827         cc(2,1,i-2)=cc(1,2,i-2)
1828         cc(2,2,i-2)=-cc(1,1,i-2)
1829         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1830         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1831         dd(2,1,i-2)=dd(1,2,i-2)
1832         dd(2,2,i-2)=-dd(1,1,i-2)
1833         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1834         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1835         do k=1,2
1836           do l=1,2
1837             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1838             EE(l,k,i-2)=sint1sq*aux
1839             if (calc_grad)
1840      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1841           enddo
1842         enddo
1843         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1844         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1845         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1846         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1847         if (calc_grad) then
1848         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1849         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1850         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1851         endif
1852 c        b1tilde(1,i-2)=b1(1,i-2)
1853 c        b1tilde(2,i-2)=-b1(2,i-2)
1854 c        b2tilde(1,i-2)=b2(1,i-2)
1855 c        b2tilde(2,i-2)=-b2(2,i-2)
1856 #ifdef DEBUG
1857         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1858         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1859         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1860         write (iout,*) 'theta=', theta(i-1)
1861 #endif
1862 #else
1863         if (i.gt. innt+2 .and. i.lt.inct+2) then
1864 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1865           iti = itype2loc(itype(i-2))
1866         else
1867           iti=nloctyp
1868         endif
1869 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
1870 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1871         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1872           iti1 = itype2loc(itype(i-1))
1873         else
1874           iti1=nloctyp
1875         endif
1876 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1877 c          iti = itype2loc(itype(i-2))
1878 c        else
1879 c          iti=nloctyp
1880 c        endif
1881 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1882 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1883 c          iti1 = itype2loc(itype(i-1))
1884 c        else
1885 c          iti1=nloctyp
1886 c        endif
1887         b1(1,i-2)=b(3,iti)
1888         b1(2,i-2)=b(5,iti)
1889         b2(1,i-2)=b(2,iti)
1890         b2(2,i-2)=b(4,iti)
1891         do k=1,2
1892           do l=1,2
1893            CC(k,l,i-2)=ccold(k,l,iti)
1894            DD(k,l,i-2)=ddold(k,l,iti)
1895            EE(k,l,i-2)=eeold(k,l,iti)
1896           enddo
1897         enddo
1898 #endif
1899         b1tilde(1,i-2)= b1(1,i-2)
1900         b1tilde(2,i-2)=-b1(2,i-2)
1901         b2tilde(1,i-2)= b2(1,i-2)
1902         b2tilde(2,i-2)=-b2(2,i-2)
1903 c
1904         Ctilde(1,1,i-2)= CC(1,1,i-2)
1905         Ctilde(1,2,i-2)= CC(1,2,i-2)
1906         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1907         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1908 c
1909         Dtilde(1,1,i-2)= DD(1,1,i-2)
1910         Dtilde(1,2,i-2)= DD(1,2,i-2)
1911         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1912         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1913 c        write(iout,*) "i",i," iti",iti
1914 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1915 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1916       enddo
1917       do i=3,nres+1
1918         if (i .lt. nres+1) then
1919           sin1=dsin(phi(i))
1920           cos1=dcos(phi(i))
1921           sintab(i-2)=sin1
1922           costab(i-2)=cos1
1923           obrot(1,i-2)=cos1
1924           obrot(2,i-2)=sin1
1925           sin2=dsin(2*phi(i))
1926           cos2=dcos(2*phi(i))
1927           sintab2(i-2)=sin2
1928           costab2(i-2)=cos2
1929           obrot2(1,i-2)=cos2
1930           obrot2(2,i-2)=sin2
1931           Ug(1,1,i-2)=-cos1
1932           Ug(1,2,i-2)=-sin1
1933           Ug(2,1,i-2)=-sin1
1934           Ug(2,2,i-2)= cos1
1935           Ug2(1,1,i-2)=-cos2
1936           Ug2(1,2,i-2)=-sin2
1937           Ug2(2,1,i-2)=-sin2
1938           Ug2(2,2,i-2)= cos2
1939         else
1940           costab(i-2)=1.0d0
1941           sintab(i-2)=0.0d0
1942           obrot(1,i-2)=1.0d0
1943           obrot(2,i-2)=0.0d0
1944           obrot2(1,i-2)=0.0d0
1945           obrot2(2,i-2)=0.0d0
1946           Ug(1,1,i-2)=1.0d0
1947           Ug(1,2,i-2)=0.0d0
1948           Ug(2,1,i-2)=0.0d0
1949           Ug(2,2,i-2)=1.0d0
1950           Ug2(1,1,i-2)=0.0d0
1951           Ug2(1,2,i-2)=0.0d0
1952           Ug2(2,1,i-2)=0.0d0
1953           Ug2(2,2,i-2)=0.0d0
1954         endif
1955         if (i .gt. 3 .and. i .lt. nres+1) then
1956           obrot_der(1,i-2)=-sin1
1957           obrot_der(2,i-2)= cos1
1958           Ugder(1,1,i-2)= sin1
1959           Ugder(1,2,i-2)=-cos1
1960           Ugder(2,1,i-2)=-cos1
1961           Ugder(2,2,i-2)=-sin1
1962           dwacos2=cos2+cos2
1963           dwasin2=sin2+sin2
1964           obrot2_der(1,i-2)=-dwasin2
1965           obrot2_der(2,i-2)= dwacos2
1966           Ug2der(1,1,i-2)= dwasin2
1967           Ug2der(1,2,i-2)=-dwacos2
1968           Ug2der(2,1,i-2)=-dwacos2
1969           Ug2der(2,2,i-2)=-dwasin2
1970         else
1971           obrot_der(1,i-2)=0.0d0
1972           obrot_der(2,i-2)=0.0d0
1973           Ugder(1,1,i-2)=0.0d0
1974           Ugder(1,2,i-2)=0.0d0
1975           Ugder(2,1,i-2)=0.0d0
1976           Ugder(2,2,i-2)=0.0d0
1977           obrot2_der(1,i-2)=0.0d0
1978           obrot2_der(2,i-2)=0.0d0
1979           Ug2der(1,1,i-2)=0.0d0
1980           Ug2der(1,2,i-2)=0.0d0
1981           Ug2der(2,1,i-2)=0.0d0
1982           Ug2der(2,2,i-2)=0.0d0
1983         endif
1984 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1985         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1986           iti = itype2loc(itype(i-2))
1987         else
1988           iti=nloctyp
1989         endif
1990 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1991         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1992           iti1 = itype2loc(itype(i-1))
1993         else
1994           iti1=nloctyp
1995         endif
1996 cd        write (iout,*) '*******i',i,' iti1',iti
1997 cd        write (iout,*) 'b1',b1(:,iti)
1998 cd        write (iout,*) 'b2',b2(:,iti)
1999 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2000 c        if (i .gt. iatel_s+2) then
2001         if (i .gt. nnt+2) then
2002           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2003 #ifdef NEWCORR
2004           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2005 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2006 #endif
2007 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
2008 c     &    EE(1,2,iti),EE(2,2,i)
2009           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2010           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2011 c          write(iout,*) "Macierz EUG",
2012 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2013 c     &    eug(2,2,i-2)
2014 #ifdef FOURBODY
2015           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2016      &    then
2017           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2018           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2019           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2020           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2021           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2022           endif
2023 #endif
2024         else
2025           do k=1,2
2026             Ub2(k,i-2)=0.0d0
2027             Ctobr(k,i-2)=0.0d0
2028             Dtobr2(k,i-2)=0.0d0
2029             do l=1,2
2030               EUg(l,k,i-2)=0.0d0
2031               CUg(l,k,i-2)=0.0d0
2032               DUg(l,k,i-2)=0.0d0
2033               DtUg2(l,k,i-2)=0.0d0
2034             enddo
2035           enddo
2036         endif
2037         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2038         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2039         do k=1,2
2040           muder(k,i-2)=Ub2der(k,i-2)
2041         enddo
2042 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2043         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2044           if (itype(i-1).le.ntyp) then
2045             iti1 = itype2loc(itype(i-1))
2046           else
2047             iti1=nloctyp
2048           endif
2049         else
2050           iti1=nloctyp
2051         endif
2052         do k=1,2
2053           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2054         enddo
2055 #ifdef MUOUT
2056         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2057      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2058      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2059      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2060      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2061      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2062 #endif
2063 cd        write (iout,*) 'mu1',mu1(:,i-2)
2064 cd        write (iout,*) 'mu2',mu2(:,i-2)
2065 #ifdef FOURBODY
2066         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2067      &  then
2068         if (calc_grad) then
2069         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2070         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2071         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2072         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2073         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2074         endif
2075 C Vectors and matrices dependent on a single virtual-bond dihedral.
2076         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2077         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2078         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2079         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2080         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2081         if (calc_grad) then
2082         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2083         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2084         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2085         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2086         endif
2087         endif
2088 #endif
2089       enddo
2090 #ifdef FOURBODY
2091 C Matrices dependent on two consecutive virtual-bond dihedrals.
2092 C The order of matrices is from left to right.
2093       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2094      &then
2095       do i=2,nres-1
2096         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2097         if (calc_grad) then
2098         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2099         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2100         endif
2101         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2102         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2103         if (calc_grad) then
2104         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2105         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2106         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2107         endif
2108       enddo
2109       endif
2110 #endif
2111       return
2112       end
2113 C--------------------------------------------------------------------------
2114       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2115 C
2116 C This subroutine calculates the average interaction energy and its gradient
2117 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2118 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2119 C The potential depends both on the distance of peptide-group centers and on
2120 C the orientation of the CA-CA virtual bonds.
2121 C
2122       implicit real*8 (a-h,o-z)
2123 #ifdef MPI
2124       include 'mpif.h'
2125 #endif
2126       include 'DIMENSIONS'
2127       include 'COMMON.CONTROL'
2128       include 'COMMON.IOUNITS'
2129       include 'COMMON.GEO'
2130       include 'COMMON.VAR'
2131       include 'COMMON.LOCAL'
2132       include 'COMMON.CHAIN'
2133       include 'COMMON.DERIV'
2134       include 'COMMON.INTERACT'
2135 #ifdef FOURBODY
2136       include 'COMMON.CONTACTS'
2137       include 'COMMON.CONTMAT'
2138 #endif
2139       include 'COMMON.CORRMAT'
2140       include 'COMMON.TORSION'
2141       include 'COMMON.VECTORS'
2142       include 'COMMON.FFIELD'
2143       include 'COMMON.TIME1'
2144       include 'COMMON.SPLITELE'
2145       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2146      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2147       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2148      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2149       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2150      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2151      &    num_conti,j1,j2
2152 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2153 #ifdef MOMENT
2154       double precision scal_el /1.0d0/
2155 #else
2156       double precision scal_el /0.5d0/
2157 #endif
2158 C 12/13/98
2159 C 13-go grudnia roku pamietnego...
2160       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2161      &                   0.0d0,1.0d0,0.0d0,
2162      &                   0.0d0,0.0d0,1.0d0/
2163 cd      write(iout,*) 'In EELEC'
2164 cd      do i=1,nloctyp
2165 cd        write(iout,*) 'Type',i
2166 cd        write(iout,*) 'B1',B1(:,i)
2167 cd        write(iout,*) 'B2',B2(:,i)
2168 cd        write(iout,*) 'CC',CC(:,:,i)
2169 cd        write(iout,*) 'DD',DD(:,:,i)
2170 cd        write(iout,*) 'EE',EE(:,:,i)
2171 cd      enddo
2172 cd      call check_vecgrad
2173 cd      stop
2174       if (icheckgrad.eq.1) then
2175         do i=1,nres-1
2176           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2177           do k=1,3
2178             dc_norm(k,i)=dc(k,i)*fac
2179           enddo
2180 c          write (iout,*) 'i',i,' fac',fac
2181         enddo
2182       endif
2183       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2184      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2185      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2186 c        call vec_and_deriv
2187 #ifdef TIMING
2188         time01=MPI_Wtime()
2189 #endif
2190         call set_matrices
2191 #ifdef TIMING
2192         time_mat=time_mat+MPI_Wtime()-time01
2193 #endif
2194       endif
2195 cd      do i=1,nres-1
2196 cd        write (iout,*) 'i=',i
2197 cd        do k=1,3
2198 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2199 cd        enddo
2200 cd        do k=1,3
2201 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2202 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2203 cd        enddo
2204 cd      enddo
2205       t_eelecij=0.0d0
2206       ees=0.0D0
2207       evdw1=0.0D0
2208       eel_loc=0.0d0
2209       eello_turn3=0.0d0
2210       eello_turn4=0.0d0
2211       ind=0
2212 #ifdef FOURBODY
2213       do i=1,nres
2214         num_cont_hb(i)=0
2215       enddo
2216 #endif
2217 cd      print '(a)','Enter EELEC'
2218 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2219 c      call flush(iout)
2220       do i=1,nres
2221         gel_loc_loc(i)=0.0d0
2222         gcorr_loc(i)=0.0d0
2223       enddo
2224 c
2225 c
2226 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2227 C
2228 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2229 C
2230 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2231       do i=iturn3_start,iturn3_end
2232 c        if (i.le.1) cycle
2233 C        write(iout,*) "tu jest i",i
2234         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2235 C changes suggested by Ana to avoid out of bounds
2236 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2237 c     & .or.((i+4).gt.nres)
2238 c     & .or.((i-1).le.0)
2239 C end of changes by Ana
2240 C dobra zmiana wycofana
2241      &  .or. itype(i+2).eq.ntyp1
2242      &  .or. itype(i+3).eq.ntyp1) cycle
2243 C Adam: Instructions below will switch off existing interactions
2244 c        if(i.gt.1)then
2245 c          if(itype(i-1).eq.ntyp1)cycle
2246 c        end if
2247 c        if(i.LT.nres-3)then
2248 c          if (itype(i+4).eq.ntyp1) cycle
2249 c        end if
2250         dxi=dc(1,i)
2251         dyi=dc(2,i)
2252         dzi=dc(3,i)
2253         dx_normi=dc_norm(1,i)
2254         dy_normi=dc_norm(2,i)
2255         dz_normi=dc_norm(3,i)
2256         xmedi=c(1,i)+0.5d0*dxi
2257         ymedi=c(2,i)+0.5d0*dyi
2258         zmedi=c(3,i)+0.5d0*dzi
2259           xmedi=mod(xmedi,boxxsize)
2260           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2261           ymedi=mod(ymedi,boxysize)
2262           if (ymedi.lt.0) ymedi=ymedi+boxysize
2263           zmedi=mod(zmedi,boxzsize)
2264           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2265         num_conti=0
2266         call eelecij(i,i+2,ees,evdw1,eel_loc)
2267         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2268 #ifdef FOURBODY
2269         num_cont_hb(i)=num_conti
2270 #endif
2271       enddo
2272       do i=iturn4_start,iturn4_end
2273         if (i.lt.1) cycle
2274         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2275 C changes suggested by Ana to avoid out of bounds
2276 c     & .or.((i+5).gt.nres)
2277 c     & .or.((i-1).le.0)
2278 C end of changes suggested by Ana
2279      &    .or. itype(i+3).eq.ntyp1
2280      &    .or. itype(i+4).eq.ntyp1
2281 c     &    .or. itype(i+5).eq.ntyp1
2282 c     &    .or. itype(i).eq.ntyp1
2283 c     &    .or. itype(i-1).eq.ntyp1
2284      &                             ) cycle
2285         dxi=dc(1,i)
2286         dyi=dc(2,i)
2287         dzi=dc(3,i)
2288         dx_normi=dc_norm(1,i)
2289         dy_normi=dc_norm(2,i)
2290         dz_normi=dc_norm(3,i)
2291         xmedi=c(1,i)+0.5d0*dxi
2292         ymedi=c(2,i)+0.5d0*dyi
2293         zmedi=c(3,i)+0.5d0*dzi
2294 C Return atom into box, boxxsize is size of box in x dimension
2295 c  194   continue
2296 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2297 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2298 C Condition for being inside the proper box
2299 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2300 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2301 c        go to 194
2302 c        endif
2303 c  195   continue
2304 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2305 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2306 C Condition for being inside the proper box
2307 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2308 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2309 c        go to 195
2310 c        endif
2311 c  196   continue
2312 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2313 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2314 C Condition for being inside the proper box
2315 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2316 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2317 c        go to 196
2318 c        endif
2319           xmedi=mod(xmedi,boxxsize)
2320           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2321           ymedi=mod(ymedi,boxysize)
2322           if (ymedi.lt.0) ymedi=ymedi+boxysize
2323           zmedi=mod(zmedi,boxzsize)
2324           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2325
2326 #ifdef FOURBODY
2327         num_conti=num_cont_hb(i)
2328 #endif
2329 c        write(iout,*) "JESTEM W PETLI"
2330         call eelecij(i,i+3,ees,evdw1,eel_loc)
2331         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2332      &   call eturn4(i,eello_turn4)
2333 #ifdef FOURBODY
2334         num_cont_hb(i)=num_conti
2335 #endif
2336       enddo   ! i
2337 C Loop over all neighbouring boxes
2338 C      do xshift=-1,1
2339 C      do yshift=-1,1
2340 C      do zshift=-1,1
2341 c
2342 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2343 c
2344 CTU KURWA
2345       do i=iatel_s,iatel_e
2346 C        do i=75,75
2347 c        if (i.le.1) cycle
2348         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2349 C changes suggested by Ana to avoid out of bounds
2350 c     & .or.((i+2).gt.nres)
2351 c     & .or.((i-1).le.0)
2352 C end of changes by Ana
2353 c     &  .or. itype(i+2).eq.ntyp1
2354 c     &  .or. itype(i-1).eq.ntyp1
2355      &                ) cycle
2356         dxi=dc(1,i)
2357         dyi=dc(2,i)
2358         dzi=dc(3,i)
2359         dx_normi=dc_norm(1,i)
2360         dy_normi=dc_norm(2,i)
2361         dz_normi=dc_norm(3,i)
2362         xmedi=c(1,i)+0.5d0*dxi
2363         ymedi=c(2,i)+0.5d0*dyi
2364         zmedi=c(3,i)+0.5d0*dzi
2365           xmedi=mod(xmedi,boxxsize)
2366           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2367           ymedi=mod(ymedi,boxysize)
2368           if (ymedi.lt.0) ymedi=ymedi+boxysize
2369           zmedi=mod(zmedi,boxzsize)
2370           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2371 C          xmedi=xmedi+xshift*boxxsize
2372 C          ymedi=ymedi+yshift*boxysize
2373 C          zmedi=zmedi+zshift*boxzsize
2374
2375 C Return tom into box, boxxsize is size of box in x dimension
2376 c  164   continue
2377 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2378 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2379 C Condition for being inside the proper box
2380 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2381 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2382 c        go to 164
2383 c        endif
2384 c  165   continue
2385 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2386 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2387 C Condition for being inside the proper box
2388 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2389 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2390 c        go to 165
2391 c        endif
2392 c  166   continue
2393 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2394 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2395 cC Condition for being inside the proper box
2396 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2397 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2398 c        go to 166
2399 c        endif
2400
2401 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2402 #ifdef FOURBODY
2403         num_conti=num_cont_hb(i)
2404 #endif
2405 C I TU KURWA
2406         do j=ielstart(i),ielend(i)
2407 C          do j=16,17
2408 C          write (iout,*) i,j
2409 C         if (j.le.1) cycle
2410           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2411 C changes suggested by Ana to avoid out of bounds
2412 c     & .or.((j+2).gt.nres)
2413 c     & .or.((j-1).le.0)
2414 C end of changes by Ana
2415 c     & .or.itype(j+2).eq.ntyp1
2416 c     & .or.itype(j-1).eq.ntyp1
2417      &) cycle
2418           call eelecij(i,j,ees,evdw1,eel_loc)
2419         enddo ! j
2420 #ifdef FOURBODY
2421         num_cont_hb(i)=num_conti
2422 #endif
2423       enddo   ! i
2424 C     enddo   ! zshift
2425 C      enddo   ! yshift
2426 C      enddo   ! xshift
2427
2428 c      write (iout,*) "Number of loop steps in EELEC:",ind
2429 cd      do i=1,nres
2430 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2431 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2432 cd      enddo
2433 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2434 ccc      eel_loc=eel_loc+eello_turn3
2435 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2436       return
2437       end
2438 C-------------------------------------------------------------------------------
2439       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2440       implicit real*8 (a-h,o-z)
2441       include 'DIMENSIONS'
2442 #ifdef MPI
2443       include "mpif.h"
2444 #endif
2445       include 'COMMON.CONTROL'
2446       include 'COMMON.IOUNITS'
2447       include 'COMMON.GEO'
2448       include 'COMMON.VAR'
2449       include 'COMMON.LOCAL'
2450       include 'COMMON.CHAIN'
2451       include 'COMMON.DERIV'
2452       include 'COMMON.INTERACT'
2453 #ifdef FOURBODY
2454       include 'COMMON.CONTACTS'
2455       include 'COMMON.CONTMAT'
2456 #endif
2457       include 'COMMON.CORRMAT'
2458       include 'COMMON.TORSION'
2459       include 'COMMON.VECTORS'
2460       include 'COMMON.FFIELD'
2461       include 'COMMON.TIME1'
2462       include 'COMMON.SPLITELE'
2463       include 'COMMON.SHIELD'
2464       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2465      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2466       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2467      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2468      &    gmuij2(4),gmuji2(4)
2469       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2470      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2471      &    num_conti,j1,j2
2472 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2473 #ifdef MOMENT
2474       double precision scal_el /1.0d0/
2475 #else
2476       double precision scal_el /0.5d0/
2477 #endif
2478 C 12/13/98
2479 C 13-go grudnia roku pamietnego...
2480       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2481      &                   0.0d0,1.0d0,0.0d0,
2482      &                   0.0d0,0.0d0,1.0d0/
2483        integer xshift,yshift,zshift
2484 c          time00=MPI_Wtime()
2485 cd      write (iout,*) "eelecij",i,j
2486 c          ind=ind+1
2487           iteli=itel(i)
2488           itelj=itel(j)
2489           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2490           aaa=app(iteli,itelj)
2491           bbb=bpp(iteli,itelj)
2492           ael6i=ael6(iteli,itelj)
2493           ael3i=ael3(iteli,itelj)
2494           dxj=dc(1,j)
2495           dyj=dc(2,j)
2496           dzj=dc(3,j)
2497           dx_normj=dc_norm(1,j)
2498           dy_normj=dc_norm(2,j)
2499           dz_normj=dc_norm(3,j)
2500 C          xj=c(1,j)+0.5D0*dxj-xmedi
2501 C          yj=c(2,j)+0.5D0*dyj-ymedi
2502 C          zj=c(3,j)+0.5D0*dzj-zmedi
2503           xj=c(1,j)+0.5D0*dxj
2504           yj=c(2,j)+0.5D0*dyj
2505           zj=c(3,j)+0.5D0*dzj
2506           xj=mod(xj,boxxsize)
2507           if (xj.lt.0) xj=xj+boxxsize
2508           yj=mod(yj,boxysize)
2509           if (yj.lt.0) yj=yj+boxysize
2510           zj=mod(zj,boxzsize)
2511           if (zj.lt.0) zj=zj+boxzsize
2512           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2513       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2514       xj_safe=xj
2515       yj_safe=yj
2516       zj_safe=zj
2517       isubchap=0
2518       do xshift=-1,1
2519       do yshift=-1,1
2520       do zshift=-1,1
2521           xj=xj_safe+xshift*boxxsize
2522           yj=yj_safe+yshift*boxysize
2523           zj=zj_safe+zshift*boxzsize
2524           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2525           if(dist_temp.lt.dist_init) then
2526             dist_init=dist_temp
2527             xj_temp=xj
2528             yj_temp=yj
2529             zj_temp=zj
2530             isubchap=1
2531           endif
2532        enddo
2533        enddo
2534        enddo
2535        if (isubchap.eq.1) then
2536           xj=xj_temp-xmedi
2537           yj=yj_temp-ymedi
2538           zj=zj_temp-zmedi
2539        else
2540           xj=xj_safe-xmedi
2541           yj=yj_safe-ymedi
2542           zj=zj_safe-zmedi
2543        endif
2544 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2545 c  174   continue
2546 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2547 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2548 C Condition for being inside the proper box
2549 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2550 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2551 c        go to 174
2552 c        endif
2553 c  175   continue
2554 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2555 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2556 C Condition for being inside the proper box
2557 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2558 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2559 c        go to 175
2560 c        endif
2561 c  176   continue
2562 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2563 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2564 C Condition for being inside the proper box
2565 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2566 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2567 c        go to 176
2568 c        endif
2569 C        endif !endPBC condintion
2570 C        xj=xj-xmedi
2571 C        yj=yj-ymedi
2572 C        zj=zj-zmedi
2573           rij=xj*xj+yj*yj+zj*zj
2574
2575           sss=sscale(sqrt(rij))
2576           if (sss.eq.0.0d0) return
2577           sssgrad=sscagrad(sqrt(rij))
2578 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2579 c     &       " rlamb",rlamb," sss",sss
2580 c            if (sss.gt.0.0d0) then
2581           rrmij=1.0D0/rij
2582           rij=dsqrt(rij)
2583           rmij=1.0D0/rij
2584           r3ij=rrmij*rmij
2585           r6ij=r3ij*r3ij
2586           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2587           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2588           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2589           fac=cosa-3.0D0*cosb*cosg
2590           ev1=aaa*r6ij*r6ij
2591 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2592           if (j.eq.i+2) ev1=scal_el*ev1
2593           ev2=bbb*r6ij
2594           fac3=ael6i*r6ij
2595           fac4=ael3i*r3ij
2596           evdwij=(ev1+ev2)
2597           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2598           el2=fac4*fac
2599 C MARYSIA
2600 C          eesij=(el1+el2)
2601 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2602           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2603           if (shield_mode.gt.0) then
2604 C          fac_shield(i)=0.4
2605 C          fac_shield(j)=0.6
2606           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2607           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2608           eesij=(el1+el2)
2609           ees=ees+eesij
2610           else
2611           fac_shield(i)=1.0
2612           fac_shield(j)=1.0
2613           eesij=(el1+el2)
2614           ees=ees+eesij
2615           endif
2616           evdw1=evdw1+evdwij*sss
2617 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2618 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2619 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2620 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2621
2622           if (energy_dec) then
2623               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2624      &'evdw1',i,j,evdwij
2625      &,iteli,itelj,aaa,evdw1,sss
2626               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2627      &fac_shield(i),fac_shield(j)
2628           endif
2629
2630 C
2631 C Calculate contributions to the Cartesian gradient.
2632 C
2633 #ifdef SPLITELE
2634           facvdw=-6*rrmij*(ev1+evdwij)*sss
2635           facel=-3*rrmij*(el1+eesij)
2636           fac1=fac
2637           erij(1)=xj*rmij
2638           erij(2)=yj*rmij
2639           erij(3)=zj*rmij
2640
2641 *
2642 * Radial derivatives. First process both termini of the fragment (i,j)
2643 *
2644           if (calc_grad) then
2645           ggg(1)=facel*xj
2646           ggg(2)=facel*yj
2647           ggg(3)=facel*zj
2648           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2649      &  (shield_mode.gt.0)) then
2650 C          print *,i,j
2651           do ilist=1,ishield_list(i)
2652            iresshield=shield_list(ilist,i)
2653            do k=1,3
2654            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2655      &      *2.0
2656            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2657      &              rlocshield
2658      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2659             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2660 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2661 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2662 C             if (iresshield.gt.i) then
2663 C               do ishi=i+1,iresshield-1
2664 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2665 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2666 C
2667 C              enddo
2668 C             else
2669 C               do ishi=iresshield,i
2670 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2671 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2672 C
2673 C               enddo
2674 C              endif
2675            enddo
2676           enddo
2677           do ilist=1,ishield_list(j)
2678            iresshield=shield_list(ilist,j)
2679            do k=1,3
2680            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2681      &     *2.0
2682            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2683      &              rlocshield
2684      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2685            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2686
2687 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2688 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2689 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2690 C             if (iresshield.gt.j) then
2691 C               do ishi=j+1,iresshield-1
2692 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2693 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2694 C
2695 C               enddo
2696 C            else
2697 C               do ishi=iresshield,j
2698 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2699 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2700 C               enddo
2701 C              endif
2702            enddo
2703           enddo
2704
2705           do k=1,3
2706             gshieldc(k,i)=gshieldc(k,i)+
2707      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2708             gshieldc(k,j)=gshieldc(k,j)+
2709      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2710             gshieldc(k,i-1)=gshieldc(k,i-1)+
2711      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2712             gshieldc(k,j-1)=gshieldc(k,j-1)+
2713      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2714
2715            enddo
2716            endif
2717 c          do k=1,3
2718 c            ghalf=0.5D0*ggg(k)
2719 c            gelc(k,i)=gelc(k,i)+ghalf
2720 c            gelc(k,j)=gelc(k,j)+ghalf
2721 c          enddo
2722 c 9/28/08 AL Gradient compotents will be summed only at the end
2723 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2724           do k=1,3
2725             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2726 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2727             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2728 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2729 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2730 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2731 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2732 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2733           enddo
2734 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2735
2736 *
2737 * Loop over residues i+1 thru j-1.
2738 *
2739 cgrad          do k=i+1,j-1
2740 cgrad            do l=1,3
2741 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2742 cgrad            enddo
2743 cgrad          enddo
2744           if (sss.gt.0.0) then
2745           facvdw=facvdw+sssgrad*rmij*evdwij
2746           ggg(1)=facvdw*xj
2747           ggg(2)=facvdw*yj
2748           ggg(3)=facvdw*zj
2749           else
2750           ggg(1)=0.0
2751           ggg(2)=0.0
2752           ggg(3)=0.0
2753           endif
2754 c          do k=1,3
2755 c            ghalf=0.5D0*ggg(k)
2756 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2757 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2758 c          enddo
2759 c 9/28/08 AL Gradient compotents will be summed only at the end
2760           do k=1,3
2761             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2762             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2763           enddo
2764 *
2765 * Loop over residues i+1 thru j-1.
2766 *
2767 cgrad          do k=i+1,j-1
2768 cgrad            do l=1,3
2769 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2770 cgrad            enddo
2771 cgrad          enddo
2772           endif ! calc_grad
2773 #else
2774 C MARYSIA
2775           facvdw=(ev1+evdwij)
2776           facel=(el1+eesij)
2777           fac1=fac
2778           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2779      &       +(evdwij+eesij)*sssgrad*rrmij
2780           erij(1)=xj*rmij
2781           erij(2)=yj*rmij
2782           erij(3)=zj*rmij
2783 *
2784 * Radial derivatives. First process both termini of the fragment (i,j)
2785 *
2786           if (calc_grad) then
2787           ggg(1)=fac*xj
2788 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2789           ggg(2)=fac*yj
2790 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2791           ggg(3)=fac*zj
2792 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2793 c          do k=1,3
2794 c            ghalf=0.5D0*ggg(k)
2795 c            gelc(k,i)=gelc(k,i)+ghalf
2796 c            gelc(k,j)=gelc(k,j)+ghalf
2797 c          enddo
2798 c 9/28/08 AL Gradient compotents will be summed only at the end
2799           do k=1,3
2800             gelc_long(k,j)=gelc(k,j)+ggg(k)
2801             gelc_long(k,i)=gelc(k,i)-ggg(k)
2802           enddo
2803 *
2804 * Loop over residues i+1 thru j-1.
2805 *
2806 cgrad          do k=i+1,j-1
2807 cgrad            do l=1,3
2808 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2809 cgrad            enddo
2810 cgrad          enddo
2811 c 9/28/08 AL Gradient compotents will be summed only at the end
2812           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2813           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2814           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2815           do k=1,3
2816             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2817             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2818           enddo
2819           endif ! calc_grad
2820 #endif
2821 *
2822 * Angular part
2823 *
2824           if (calc_grad) then
2825           ecosa=2.0D0*fac3*fac1+fac4
2826           fac4=-3.0D0*fac4
2827           fac3=-6.0D0*fac3
2828           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2829           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2830           do k=1,3
2831             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2832             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2833           enddo
2834 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2835 cd   &          (dcosg(k),k=1,3)
2836           do k=1,3
2837             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2838      &      fac_shield(i)**2*fac_shield(j)**2
2839           enddo
2840 c          do k=1,3
2841 c            ghalf=0.5D0*ggg(k)
2842 c            gelc(k,i)=gelc(k,i)+ghalf
2843 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2844 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2845 c            gelc(k,j)=gelc(k,j)+ghalf
2846 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2847 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2848 c          enddo
2849 cgrad          do k=i+1,j-1
2850 cgrad            do l=1,3
2851 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2852 cgrad            enddo
2853 cgrad          enddo
2854 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2855           do k=1,3
2856             gelc(k,i)=gelc(k,i)
2857      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2858      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2859      &           *fac_shield(i)**2*fac_shield(j)**2
2860             gelc(k,j)=gelc(k,j)
2861      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2862      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2863      &           *fac_shield(i)**2*fac_shield(j)**2
2864             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2865             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2866           enddo
2867 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2868
2869 C MARYSIA
2870 c          endif !sscale
2871           endif ! calc_grad
2872           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2873      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2874      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2875 C
2876 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2877 C   energy of a peptide unit is assumed in the form of a second-order
2878 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2879 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2880 C   are computed for EVERY pair of non-contiguous peptide groups.
2881 C
2882
2883           if (j.lt.nres-1) then
2884             j1=j+1
2885             j2=j-1
2886           else
2887             j1=j-1
2888             j2=j-2
2889           endif
2890           kkk=0
2891           lll=0
2892           do k=1,2
2893             do l=1,2
2894               kkk=kkk+1
2895               muij(kkk)=mu(k,i)*mu(l,j)
2896 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2897 #ifdef NEWCORR
2898              if (calc_grad) then
2899              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2900 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2901              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2902              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2903 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2904              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2905              endif
2906 #endif
2907             enddo
2908           enddo
2909 #ifdef DEBUG
2910           write (iout,*) 'EELEC: i',i,' j',j
2911           write (iout,*) 'j',j,' j1',j1,' j2',j2
2912           write(iout,*) 'muij',muij
2913           write (iout,*) "uy",uy(:,i)
2914           write (iout,*) "uz",uz(:,j)
2915           write (iout,*) "erij",erij
2916 #endif
2917           ury=scalar(uy(1,i),erij)
2918           urz=scalar(uz(1,i),erij)
2919           vry=scalar(uy(1,j),erij)
2920           vrz=scalar(uz(1,j),erij)
2921           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2922           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2923           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2924           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2925           fac=dsqrt(-ael6i)*r3ij
2926           a22=a22*fac
2927           a23=a23*fac
2928           a32=a32*fac
2929           a33=a33*fac
2930 cd          write (iout,'(4i5,4f10.5)')
2931 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2932 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2933 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2934 cd     &      uy(:,j),uz(:,j)
2935 cd          write (iout,'(4f10.5)')
2936 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2937 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2938 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2939 cd           write (iout,'(9f10.5/)')
2940 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2941 C Derivatives of the elements of A in virtual-bond vectors
2942           if (calc_grad) then
2943           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2944           do k=1,3
2945             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2946             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2947             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2948             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2949             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2950             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2951             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2952             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2953             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2954             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2955             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2956             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2957           enddo
2958 C Compute radial contributions to the gradient
2959           facr=-3.0d0*rrmij
2960           a22der=a22*facr
2961           a23der=a23*facr
2962           a32der=a32*facr
2963           a33der=a33*facr
2964           agg(1,1)=a22der*xj
2965           agg(2,1)=a22der*yj
2966           agg(3,1)=a22der*zj
2967           agg(1,2)=a23der*xj
2968           agg(2,2)=a23der*yj
2969           agg(3,2)=a23der*zj
2970           agg(1,3)=a32der*xj
2971           agg(2,3)=a32der*yj
2972           agg(3,3)=a32der*zj
2973           agg(1,4)=a33der*xj
2974           agg(2,4)=a33der*yj
2975           agg(3,4)=a33der*zj
2976 C Add the contributions coming from er
2977           fac3=-3.0d0*fac
2978           do k=1,3
2979             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2980             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2981             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2982             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2983           enddo
2984           do k=1,3
2985 C Derivatives in DC(i)
2986 cgrad            ghalf1=0.5d0*agg(k,1)
2987 cgrad            ghalf2=0.5d0*agg(k,2)
2988 cgrad            ghalf3=0.5d0*agg(k,3)
2989 cgrad            ghalf4=0.5d0*agg(k,4)
2990             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2991      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2992             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2993      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2994             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2995      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2996             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2997      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2998 C Derivatives in DC(i+1)
2999             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3000      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3001             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3002      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3003             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3004      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3005             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3006      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3007 C Derivatives in DC(j)
3008             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3009      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3010             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3011      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3012             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3013      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3014             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3015      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3016 C Derivatives in DC(j+1) or DC(nres-1)
3017             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3018      &      -3.0d0*vryg(k,3)*ury)
3019             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3020      &      -3.0d0*vrzg(k,3)*ury)
3021             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3022      &      -3.0d0*vryg(k,3)*urz)
3023             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3024      &      -3.0d0*vrzg(k,3)*urz)
3025 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3026 cgrad              do l=1,4
3027 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3028 cgrad              enddo
3029 cgrad            endif
3030           enddo
3031           endif ! calc_grad
3032           acipa(1,1)=a22
3033           acipa(1,2)=a23
3034           acipa(2,1)=a32
3035           acipa(2,2)=a33
3036           a22=-a22
3037           a23=-a23
3038           if (calc_grad) then
3039           do l=1,2
3040             do k=1,3
3041               agg(k,l)=-agg(k,l)
3042               aggi(k,l)=-aggi(k,l)
3043               aggi1(k,l)=-aggi1(k,l)
3044               aggj(k,l)=-aggj(k,l)
3045               aggj1(k,l)=-aggj1(k,l)
3046             enddo
3047           enddo
3048           endif ! calc_grad
3049           if (j.lt.nres-1) then
3050             a22=-a22
3051             a32=-a32
3052             do l=1,3,2
3053               do k=1,3
3054                 agg(k,l)=-agg(k,l)
3055                 aggi(k,l)=-aggi(k,l)
3056                 aggi1(k,l)=-aggi1(k,l)
3057                 aggj(k,l)=-aggj(k,l)
3058                 aggj1(k,l)=-aggj1(k,l)
3059               enddo
3060             enddo
3061           else
3062             a22=-a22
3063             a23=-a23
3064             a32=-a32
3065             a33=-a33
3066             do l=1,4
3067               do k=1,3
3068                 agg(k,l)=-agg(k,l)
3069                 aggi(k,l)=-aggi(k,l)
3070                 aggi1(k,l)=-aggi1(k,l)
3071                 aggj(k,l)=-aggj(k,l)
3072                 aggj1(k,l)=-aggj1(k,l)
3073               enddo
3074             enddo
3075           endif
3076           ENDIF ! WCORR
3077           IF (wel_loc.gt.0.0d0) THEN
3078 C Contribution to the local-electrostatic energy coming from the i-j pair
3079           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3080      &     +a33*muij(4)
3081 #ifdef DEBUG
3082           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3083      &     " a33",a33
3084           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3085      &     " wel_loc",wel_loc
3086 #endif
3087           if (shield_mode.eq.0) then
3088            fac_shield(i)=1.0
3089            fac_shield(j)=1.0
3090 C          else
3091 C           fac_shield(i)=0.4
3092 C           fac_shield(j)=0.6
3093           endif
3094           eel_loc_ij=eel_loc_ij
3095      &    *fac_shield(i)*fac_shield(j)
3096           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3097      &            'eelloc',i,j,eel_loc_ij
3098 c           if (eel_loc_ij.ne.0)
3099 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3100 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3101
3102           eel_loc=eel_loc+eel_loc_ij*sss
3103 C Now derivative over eel_loc
3104           if (calc_grad) then
3105           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3106      &  (shield_mode.gt.0)) then
3107 C          print *,i,j
3108
3109           do ilist=1,ishield_list(i)
3110            iresshield=shield_list(ilist,i)
3111            do k=1,3
3112            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3113      &                                          /fac_shield(i)
3114 C     &      *2.0
3115            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3116      &              rlocshield
3117      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3118             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3119      &      +rlocshield
3120            enddo
3121           enddo
3122           do ilist=1,ishield_list(j)
3123            iresshield=shield_list(ilist,j)
3124            do k=1,3
3125            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3126      &                                       /fac_shield(j)
3127 C     &     *2.0
3128            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3129      &              rlocshield
3130      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3131            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3132      &             +rlocshield
3133
3134            enddo
3135           enddo
3136
3137           do k=1,3
3138             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3139      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3140             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3141      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3142             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3143      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3144             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3145      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3146            enddo
3147            endif
3148
3149
3150 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3151 c     &                     ' eel_loc_ij',eel_loc_ij
3152 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3153 C Calculate patrial derivative for theta angle
3154 #ifdef NEWCORR
3155          geel_loc_ij=(a22*gmuij1(1)
3156      &     +a23*gmuij1(2)
3157      &     +a32*gmuij1(3)
3158      &     +a33*gmuij1(4))
3159      &    *fac_shield(i)*fac_shield(j)*sss
3160 c         write(iout,*) "derivative over thatai"
3161 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3162 c     &   a33*gmuij1(4)
3163          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3164      &      geel_loc_ij*wel_loc
3165 c         write(iout,*) "derivative over thatai-1"
3166 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3167 c     &   a33*gmuij2(4)
3168          geel_loc_ij=
3169      &     a22*gmuij2(1)
3170      &     +a23*gmuij2(2)
3171      &     +a32*gmuij2(3)
3172      &     +a33*gmuij2(4)
3173          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3174      &      geel_loc_ij*wel_loc
3175      &    *fac_shield(i)*fac_shield(j)*sss
3176
3177 c  Derivative over j residue
3178          geel_loc_ji=a22*gmuji1(1)
3179      &     +a23*gmuji1(2)
3180      &     +a32*gmuji1(3)
3181      &     +a33*gmuji1(4)
3182 c         write(iout,*) "derivative over thataj"
3183 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3184 c     &   a33*gmuji1(4)
3185
3186         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3187      &      geel_loc_ji*wel_loc
3188      &    *fac_shield(i)*fac_shield(j)
3189
3190          geel_loc_ji=
3191      &     +a22*gmuji2(1)
3192      &     +a23*gmuji2(2)
3193      &     +a32*gmuji2(3)
3194      &     +a33*gmuji2(4)
3195 c         write(iout,*) "derivative over thataj-1"
3196 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3197 c     &   a33*gmuji2(4)
3198          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3199      &      geel_loc_ji*wel_loc
3200      &    *fac_shield(i)*fac_shield(j)*sss
3201 #endif
3202 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3203
3204 C Partial derivatives in virtual-bond dihedral angles gamma
3205           if (i.gt.1)
3206      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3207      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3208      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3209      &    *fac_shield(i)*fac_shield(j)
3210
3211           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3212      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3213      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3214      &    *fac_shield(i)*fac_shield(j)
3215 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3216           aux=eel_loc_ij/sss*sssgrad*rmij
3217           ggg(1)=aux*xj
3218           ggg(2)=aux*yj
3219           ggg(3)=aux*zj
3220           do l=1,3
3221             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3222      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3223      &    *fac_shield(i)*fac_shield(j)*sss
3224             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3225             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3226 cgrad            ghalf=0.5d0*ggg(l)
3227 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3228 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3229           enddo
3230 cgrad          do k=i+1,j2
3231 cgrad            do l=1,3
3232 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3233 cgrad            enddo
3234 cgrad          enddo
3235 C Remaining derivatives of eello
3236           do l=1,3
3237             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3238      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3239      &    *fac_shield(i)*fac_shield(j)
3240
3241             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3242      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3243      &    *fac_shield(i)*fac_shield(j)
3244
3245             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3246      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3247      &    *fac_shield(i)*fac_shield(j)
3248
3249             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3250      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3251      &    *fac_shield(i)*fac_shield(j)
3252
3253           enddo
3254           endif ! calc_grad
3255           ENDIF
3256
3257
3258 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3259 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3260 #ifdef FOURBODY
3261           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3262      &       .and. num_conti.le.maxconts) then
3263 c            write (iout,*) i,j," entered corr"
3264 C
3265 C Calculate the contact function. The ith column of the array JCONT will
3266 C contain the numbers of atoms that make contacts with the atom I (of numbers
3267 C greater than I). The arrays FACONT and GACONT will contain the values of
3268 C the contact function and its derivative.
3269 c           r0ij=1.02D0*rpp(iteli,itelj)
3270 c           r0ij=1.11D0*rpp(iteli,itelj)
3271             r0ij=2.20D0*rpp(iteli,itelj)
3272 c           r0ij=1.55D0*rpp(iteli,itelj)
3273             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3274             if (fcont.gt.0.0D0) then
3275               num_conti=num_conti+1
3276               if (num_conti.gt.maxconts) then
3277                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3278      &                         ' will skip next contacts for this conf.'
3279               else
3280                 jcont_hb(num_conti,i)=j
3281 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3282 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3283                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3284      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3285 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3286 C  terms.
3287                 d_cont(num_conti,i)=rij
3288 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3289 C     --- Electrostatic-interaction matrix ---
3290                 a_chuj(1,1,num_conti,i)=a22
3291                 a_chuj(1,2,num_conti,i)=a23
3292                 a_chuj(2,1,num_conti,i)=a32
3293                 a_chuj(2,2,num_conti,i)=a33
3294 C     --- Gradient of rij
3295                 if (calc_grad) then
3296                 do kkk=1,3
3297                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3298                 enddo
3299                 kkll=0
3300                 do k=1,2
3301                   do l=1,2
3302                     kkll=kkll+1
3303                     do m=1,3
3304                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3305                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3306                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3307                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3308                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3309                     enddo
3310                   enddo
3311                 enddo
3312                 endif ! calc_grad
3313                 ENDIF
3314                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3315 C Calculate contact energies
3316                 cosa4=4.0D0*cosa
3317                 wij=cosa-3.0D0*cosb*cosg
3318                 cosbg1=cosb+cosg
3319                 cosbg2=cosb-cosg
3320 c               fac3=dsqrt(-ael6i)/r0ij**3
3321                 fac3=dsqrt(-ael6i)*r3ij
3322 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3323                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3324                 if (ees0tmp.gt.0) then
3325                   ees0pij=dsqrt(ees0tmp)
3326                 else
3327                   ees0pij=0
3328                 endif
3329 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3330                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3331                 if (ees0tmp.gt.0) then
3332                   ees0mij=dsqrt(ees0tmp)
3333                 else
3334                   ees0mij=0
3335                 endif
3336 c               ees0mij=0.0D0
3337                 if (shield_mode.eq.0) then
3338                 fac_shield(i)=1.0d0
3339                 fac_shield(j)=1.0d0
3340                 else
3341                 ees0plist(num_conti,i)=j
3342 C                fac_shield(i)=0.4d0
3343 C                fac_shield(j)=0.6d0
3344                 endif
3345                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3346      &          *fac_shield(i)*fac_shield(j)
3347                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3348      &          *fac_shield(i)*fac_shield(j)
3349 C Diagnostics. Comment out or remove after debugging!
3350 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3351 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3352 c               ees0m(num_conti,i)=0.0D0
3353 C End diagnostics.
3354 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3355 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3356 C Angular derivatives of the contact function
3357
3358                 ees0pij1=fac3/ees0pij
3359                 ees0mij1=fac3/ees0mij
3360                 fac3p=-3.0D0*fac3*rrmij
3361                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3362                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3363 c               ees0mij1=0.0D0
3364                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3365                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3366                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3367                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3368                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3369                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3370                 ecosap=ecosa1+ecosa2
3371                 ecosbp=ecosb1+ecosb2
3372                 ecosgp=ecosg1+ecosg2
3373                 ecosam=ecosa1-ecosa2
3374                 ecosbm=ecosb1-ecosb2
3375                 ecosgm=ecosg1-ecosg2
3376 C Diagnostics
3377 c               ecosap=ecosa1
3378 c               ecosbp=ecosb1
3379 c               ecosgp=ecosg1
3380 c               ecosam=0.0D0
3381 c               ecosbm=0.0D0
3382 c               ecosgm=0.0D0
3383 C End diagnostics
3384                 facont_hb(num_conti,i)=fcont
3385
3386                 if (calc_grad) then
3387                 fprimcont=fprimcont/rij
3388 cd              facont_hb(num_conti,i)=1.0D0
3389 C Following line is for diagnostics.
3390 cd              fprimcont=0.0D0
3391                 do k=1,3
3392                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3393                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3394                 enddo
3395                 do k=1,3
3396                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3397                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3398                 enddo
3399                 gggp(1)=gggp(1)+ees0pijp*xj
3400      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3401                 gggp(2)=gggp(2)+ees0pijp*yj
3402      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3403                 gggp(3)=gggp(3)+ees0pijp*zj
3404      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3405                 gggm(1)=gggm(1)+ees0mijp*xj
3406      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3407                 gggm(2)=gggm(2)+ees0mijp*yj
3408      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3409                 gggm(3)=gggm(3)+ees0mijp*zj
3410      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3411 C Derivatives due to the contact function
3412                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3413                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3414                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3415                 do k=1,3
3416 c
3417 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3418 c          following the change of gradient-summation algorithm.
3419 c
3420 cgrad                  ghalfp=0.5D0*gggp(k)
3421 cgrad                  ghalfm=0.5D0*gggm(k)
3422                   gacontp_hb1(k,num_conti,i)=!ghalfp
3423      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3424      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3425      &          *fac_shield(i)*fac_shield(j)*sss
3426
3427                   gacontp_hb2(k,num_conti,i)=!ghalfp
3428      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3429      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3430      &          *fac_shield(i)*fac_shield(j)*sss
3431
3432                   gacontp_hb3(k,num_conti,i)=gggp(k)
3433      &          *fac_shield(i)*fac_shield(j)*sss
3434
3435                   gacontm_hb1(k,num_conti,i)=!ghalfm
3436      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3437      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3438      &          *fac_shield(i)*fac_shield(j)*sss
3439
3440                   gacontm_hb2(k,num_conti,i)=!ghalfm
3441      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3442      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3443      &          *fac_shield(i)*fac_shield(j)*sss
3444
3445                   gacontm_hb3(k,num_conti,i)=gggm(k)
3446      &          *fac_shield(i)*fac_shield(j)
3447 *sss
3448                 enddo
3449 C Diagnostics. Comment out or remove after debugging!
3450 cdiag           do k=1,3
3451 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3452 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3453 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3454 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3455 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3456 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3457 cdiag           enddo
3458
3459                  endif ! calc_grad
3460
3461               ENDIF ! wcorr
3462               endif  ! num_conti.le.maxconts
3463             endif  ! fcont.gt.0
3464           endif    ! j.gt.i+1
3465 #endif
3466           if (calc_grad) then
3467           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3468             do k=1,4
3469               do l=1,3
3470                 ghalf=0.5d0*agg(l,k)
3471                 aggi(l,k)=aggi(l,k)+ghalf
3472                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3473                 aggj(l,k)=aggj(l,k)+ghalf
3474               enddo
3475             enddo
3476             if (j.eq.nres-1 .and. i.lt.j-2) then
3477               do k=1,4
3478                 do l=1,3
3479                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3480                 enddo
3481               enddo
3482             endif
3483           endif
3484           endif ! calc_grad
3485 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3486       return
3487       end
3488 C-----------------------------------------------------------------------------
3489       subroutine eturn3(i,eello_turn3)
3490 C Third- and fourth-order contributions from turns
3491       implicit real*8 (a-h,o-z)
3492       include 'DIMENSIONS'
3493       include 'COMMON.IOUNITS'
3494       include 'COMMON.GEO'
3495       include 'COMMON.VAR'
3496       include 'COMMON.LOCAL'
3497       include 'COMMON.CHAIN'
3498       include 'COMMON.DERIV'
3499       include 'COMMON.INTERACT'
3500       include 'COMMON.CORRMAT'
3501       include 'COMMON.TORSION'
3502       include 'COMMON.VECTORS'
3503       include 'COMMON.FFIELD'
3504       include 'COMMON.CONTROL'
3505       include 'COMMON.SHIELD'
3506       dimension ggg(3)
3507       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3508      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3509      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3510      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3511      &  auxgmat2(2,2),auxgmatt2(2,2)
3512       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3513      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3514       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3515      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3516      &    num_conti,j1,j2
3517       j=i+2
3518 c      write (iout,*) "eturn3",i,j,j1,j2
3519       a_temp(1,1)=a22
3520       a_temp(1,2)=a23
3521       a_temp(2,1)=a32
3522       a_temp(2,2)=a33
3523 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3524 C
3525 C               Third-order contributions
3526 C
3527 C                 (i+2)o----(i+3)
3528 C                      | |
3529 C                      | |
3530 C                 (i+1)o----i
3531 C
3532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3533 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3534         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3535 c auxalary matices for theta gradient
3536 c auxalary matrix for i+1 and constant i+2
3537         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3538 c auxalary matrix for i+2 and constant i+1
3539         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3540         call transpose2(auxmat(1,1),auxmat1(1,1))
3541         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3542         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3543         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3544         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3545         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3546         if (shield_mode.eq.0) then
3547         fac_shield(i)=1.0
3548         fac_shield(j)=1.0
3549 C        else
3550 C        fac_shield(i)=0.4
3551 C        fac_shield(j)=0.6
3552         endif
3553         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3554      &  *fac_shield(i)*fac_shield(j)
3555         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3556      &  *fac_shield(i)*fac_shield(j)
3557         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3558      &    eello_t3
3559         if (calc_grad) then
3560 C#ifdef NEWCORR
3561 C Derivatives in theta
3562         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3563      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3564      &   *fac_shield(i)*fac_shield(j)
3565         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3566      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3567      &   *fac_shield(i)*fac_shield(j)
3568 C#endif
3569
3570 C Derivatives in shield mode
3571           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3572      &  (shield_mode.gt.0)) then
3573 C          print *,i,j
3574
3575           do ilist=1,ishield_list(i)
3576            iresshield=shield_list(ilist,i)
3577            do k=1,3
3578            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3579 C     &      *2.0
3580            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3581      &              rlocshield
3582      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3583             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3584      &      +rlocshield
3585            enddo
3586           enddo
3587           do ilist=1,ishield_list(j)
3588            iresshield=shield_list(ilist,j)
3589            do k=1,3
3590            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3591 C     &     *2.0
3592            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3593      &              rlocshield
3594      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3595            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3596      &             +rlocshield
3597
3598            enddo
3599           enddo
3600
3601           do k=1,3
3602             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3603      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3604             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3605      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3606             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3607      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3608             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3609      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3610            enddo
3611            endif
3612
3613 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3614 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3615 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3616 cd     &    ' eello_turn3_num',4*eello_turn3_num
3617 C Derivatives in gamma(i)
3618         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3619         call transpose2(auxmat2(1,1),auxmat3(1,1))
3620         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3621         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3622      &   *fac_shield(i)*fac_shield(j)
3623 C Derivatives in gamma(i+1)
3624         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3625         call transpose2(auxmat2(1,1),auxmat3(1,1))
3626         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3627         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3628      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3629      &   *fac_shield(i)*fac_shield(j)
3630 C Cartesian derivatives
3631         do l=1,3
3632 c            ghalf1=0.5d0*agg(l,1)
3633 c            ghalf2=0.5d0*agg(l,2)
3634 c            ghalf3=0.5d0*agg(l,3)
3635 c            ghalf4=0.5d0*agg(l,4)
3636           a_temp(1,1)=aggi(l,1)!+ghalf1
3637           a_temp(1,2)=aggi(l,2)!+ghalf2
3638           a_temp(2,1)=aggi(l,3)!+ghalf3
3639           a_temp(2,2)=aggi(l,4)!+ghalf4
3640           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3641           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3642      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3643      &   *fac_shield(i)*fac_shield(j)
3644
3645           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3646           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3647           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3648           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3649           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3650           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3651      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3652      &   *fac_shield(i)*fac_shield(j)
3653           a_temp(1,1)=aggj(l,1)!+ghalf1
3654           a_temp(1,2)=aggj(l,2)!+ghalf2
3655           a_temp(2,1)=aggj(l,3)!+ghalf3
3656           a_temp(2,2)=aggj(l,4)!+ghalf4
3657           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3658           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3659      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3660      &   *fac_shield(i)*fac_shield(j)
3661           a_temp(1,1)=aggj1(l,1)
3662           a_temp(1,2)=aggj1(l,2)
3663           a_temp(2,1)=aggj1(l,3)
3664           a_temp(2,2)=aggj1(l,4)
3665           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3666           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3667      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3668      &   *fac_shield(i)*fac_shield(j)
3669         enddo
3670
3671         endif ! calc_grad
3672
3673       return
3674       end
3675 C-------------------------------------------------------------------------------
3676       subroutine eturn4(i,eello_turn4)
3677 C Third- and fourth-order contributions from turns
3678       implicit real*8 (a-h,o-z)
3679       include 'DIMENSIONS'
3680       include 'COMMON.IOUNITS'
3681       include 'COMMON.GEO'
3682       include 'COMMON.VAR'
3683       include 'COMMON.LOCAL'
3684       include 'COMMON.CHAIN'
3685       include 'COMMON.DERIV'
3686       include 'COMMON.INTERACT'
3687       include 'COMMON.CORRMAT'
3688       include 'COMMON.TORSION'
3689       include 'COMMON.VECTORS'
3690       include 'COMMON.FFIELD'
3691       include 'COMMON.CONTROL'
3692       include 'COMMON.SHIELD'
3693       dimension ggg(3)
3694       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3695      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3696      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3697      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3698      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3699      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3700      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3701       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3702      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3703       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3704      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3705      &    num_conti,j1,j2
3706       j=i+3
3707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3708 C
3709 C               Fourth-order contributions
3710 C
3711 C                 (i+3)o----(i+4)
3712 C                     /  |
3713 C               (i+2)o   |
3714 C                     \  |
3715 C                 (i+1)o----i
3716 C
3717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3718 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3719 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3720 c        write(iout,*)"WCHODZE W PROGRAM"
3721         a_temp(1,1)=a22
3722         a_temp(1,2)=a23
3723         a_temp(2,1)=a32
3724         a_temp(2,2)=a33
3725         iti1=itype2loc(itype(i+1))
3726         iti2=itype2loc(itype(i+2))
3727         iti3=itype2loc(itype(i+3))
3728 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3729         call transpose2(EUg(1,1,i+1),e1t(1,1))
3730         call transpose2(Eug(1,1,i+2),e2t(1,1))
3731         call transpose2(Eug(1,1,i+3),e3t(1,1))
3732 C Ematrix derivative in theta
3733         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3734         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3735         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3736         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3737 c       eta1 in derivative theta
3738         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3739         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3740 c       auxgvec is derivative of Ub2 so i+3 theta
3741         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3742 c       auxalary matrix of E i+1
3743         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3744 c        s1=0.0
3745 c        gs1=0.0
3746         s1=scalar2(b1(1,i+2),auxvec(1))
3747 c derivative of theta i+2 with constant i+3
3748         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3749 c derivative of theta i+2 with constant i+2
3750         gs32=scalar2(b1(1,i+2),auxgvec(1))
3751 c derivative of E matix in theta of i+1
3752         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3753
3754         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3755 c       ea31 in derivative theta
3756         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3757         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3758 c auxilary matrix auxgvec of Ub2 with constant E matirx
3759         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3760 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3761         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3762
3763 c        s2=0.0
3764 c        gs2=0.0
3765         s2=scalar2(b1(1,i+1),auxvec(1))
3766 c derivative of theta i+1 with constant i+3
3767         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3768 c derivative of theta i+2 with constant i+1
3769         gs21=scalar2(b1(1,i+1),auxgvec(1))
3770 c derivative of theta i+3 with constant i+1
3771         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3772 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3773 c     &  gtb1(1,i+1)
3774         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3775 c two derivatives over diffetent matrices
3776 c gtae3e2 is derivative over i+3
3777         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3778 c ae3gte2 is derivative over i+2
3779         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3780         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3781 c three possible derivative over theta E matices
3782 c i+1
3783         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3784 c i+2
3785         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3786 c i+3
3787         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3788         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3789
3790         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3791         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3792         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3793         if (shield_mode.eq.0) then
3794         fac_shield(i)=1.0
3795         fac_shield(j)=1.0
3796 C        else
3797 C        fac_shield(i)=0.6
3798 C        fac_shield(j)=0.4
3799         endif
3800         eello_turn4=eello_turn4-(s1+s2+s3)
3801      &  *fac_shield(i)*fac_shield(j)
3802         eello_t4=-(s1+s2+s3)
3803      &  *fac_shield(i)*fac_shield(j)
3804 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3805         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3806      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3807 C Now derivative over shield:
3808           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3809      &  (shield_mode.gt.0)) then
3810 C          print *,i,j
3811
3812           do ilist=1,ishield_list(i)
3813            iresshield=shield_list(ilist,i)
3814            do k=1,3
3815            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3816 C     &      *2.0
3817            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3818      &              rlocshield
3819      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3820             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3821      &      +rlocshield
3822            enddo
3823           enddo
3824           do ilist=1,ishield_list(j)
3825            iresshield=shield_list(ilist,j)
3826            do k=1,3
3827            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3828 C     &     *2.0
3829            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3830      &              rlocshield
3831      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3832            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3833      &             +rlocshield
3834
3835            enddo
3836           enddo
3837
3838           do k=1,3
3839             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3840      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3841             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3842      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3843             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3844      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3845             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3846      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3847            enddo
3848            endif
3849 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3850 cd     &    ' eello_turn4_num',8*eello_turn4_num
3851 #ifdef NEWCORR
3852         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3853      &                  -(gs13+gsE13+gsEE1)*wturn4
3854      &  *fac_shield(i)*fac_shield(j)
3855         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3856      &                    -(gs23+gs21+gsEE2)*wturn4
3857      &  *fac_shield(i)*fac_shield(j)
3858
3859         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3860      &                    -(gs32+gsE31+gsEE3)*wturn4
3861      &  *fac_shield(i)*fac_shield(j)
3862
3863 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3864 c     &   gs2
3865 #endif
3866         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3867      &      'eturn4',i,j,-(s1+s2+s3)
3868 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3869 c     &    ' eello_turn4_num',8*eello_turn4_num
3870 C Derivatives in gamma(i)
3871         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3872         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3873         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,i+2),auxvec(1))
3875         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3876         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3877         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3878      &  *fac_shield(i)*fac_shield(j)
3879 C Derivatives in gamma(i+1)
3880         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3881         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3882         s2=scalar2(b1(1,i+1),auxvec(1))
3883         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3884         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3885         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3886         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3887      &  *fac_shield(i)*fac_shield(j)
3888 C Derivatives in gamma(i+2)
3889         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3890         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3891         s1=scalar2(b1(1,i+2),auxvec(1))
3892         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3893         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3894         s2=scalar2(b1(1,i+1),auxvec(1))
3895         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3896         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3897         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3898         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3899      &  *fac_shield(i)*fac_shield(j)
3900         if (calc_grad) then
3901 C Cartesian derivatives
3902 C Derivatives of this turn contributions in DC(i+2)
3903         if (j.lt.nres-1) then
3904           do l=1,3
3905             a_temp(1,1)=agg(l,1)
3906             a_temp(1,2)=agg(l,2)
3907             a_temp(2,1)=agg(l,3)
3908             a_temp(2,2)=agg(l,4)
3909             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3910             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3911             s1=scalar2(b1(1,i+2),auxvec(1))
3912             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3913             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3914             s2=scalar2(b1(1,i+1),auxvec(1))
3915             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3916             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3917             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918             ggg(l)=-(s1+s2+s3)
3919             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3920      &  *fac_shield(i)*fac_shield(j)
3921           enddo
3922         endif
3923 C Remaining derivatives of this turn contribution
3924         do l=1,3
3925           a_temp(1,1)=aggi(l,1)
3926           a_temp(1,2)=aggi(l,2)
3927           a_temp(2,1)=aggi(l,3)
3928           a_temp(2,2)=aggi(l,4)
3929           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3930           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3931           s1=scalar2(b1(1,i+2),auxvec(1))
3932           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3933           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3934           s2=scalar2(b1(1,i+1),auxvec(1))
3935           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3936           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3937           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3939      &  *fac_shield(i)*fac_shield(j)
3940           a_temp(1,1)=aggi1(l,1)
3941           a_temp(1,2)=aggi1(l,2)
3942           a_temp(2,1)=aggi1(l,3)
3943           a_temp(2,2)=aggi1(l,4)
3944           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3945           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3946           s1=scalar2(b1(1,i+2),auxvec(1))
3947           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3948           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3949           s2=scalar2(b1(1,i+1),auxvec(1))
3950           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3951           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3952           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3953           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3954      &  *fac_shield(i)*fac_shield(j)
3955           a_temp(1,1)=aggj(l,1)
3956           a_temp(1,2)=aggj(l,2)
3957           a_temp(2,1)=aggj(l,3)
3958           a_temp(2,2)=aggj(l,4)
3959           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3960           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3961           s1=scalar2(b1(1,i+2),auxvec(1))
3962           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3963           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3964           s2=scalar2(b1(1,i+1),auxvec(1))
3965           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3966           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3967           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3968           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3969      &  *fac_shield(i)*fac_shield(j)
3970           a_temp(1,1)=aggj1(l,1)
3971           a_temp(1,2)=aggj1(l,2)
3972           a_temp(2,1)=aggj1(l,3)
3973           a_temp(2,2)=aggj1(l,4)
3974           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3975           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3976           s1=scalar2(b1(1,i+2),auxvec(1))
3977           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3978           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3979           s2=scalar2(b1(1,i+1),auxvec(1))
3980           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3981           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3982           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3983 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3984           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3985      &  *fac_shield(i)*fac_shield(j)
3986         enddo
3987
3988         endif ! calc_grad
3989
3990       return
3991       end
3992 C-----------------------------------------------------------------------------
3993       subroutine vecpr(u,v,w)
3994       implicit real*8(a-h,o-z)
3995       dimension u(3),v(3),w(3)
3996       w(1)=u(2)*v(3)-u(3)*v(2)
3997       w(2)=-u(1)*v(3)+u(3)*v(1)
3998       w(3)=u(1)*v(2)-u(2)*v(1)
3999       return
4000       end
4001 C-----------------------------------------------------------------------------
4002       subroutine unormderiv(u,ugrad,unorm,ungrad)
4003 C This subroutine computes the derivatives of a normalized vector u, given
4004 C the derivatives computed without normalization conditions, ugrad. Returns
4005 C ungrad.
4006       implicit none
4007       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4008       double precision vec(3)
4009       double precision scalar
4010       integer i,j
4011 c      write (2,*) 'ugrad',ugrad
4012 c      write (2,*) 'u',u
4013       do i=1,3
4014         vec(i)=scalar(ugrad(1,i),u(1))
4015       enddo
4016 c      write (2,*) 'vec',vec
4017       do i=1,3
4018         do j=1,3
4019           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4020         enddo
4021       enddo
4022 c      write (2,*) 'ungrad',ungrad
4023       return
4024       end
4025 C-----------------------------------------------------------------------------
4026       subroutine escp(evdw2,evdw2_14)
4027 C
4028 C This subroutine calculates the excluded-volume interaction energy between
4029 C peptide-group centers and side chains and its gradient in virtual-bond and
4030 C side-chain vectors.
4031 C
4032       implicit real*8 (a-h,o-z)
4033       include 'DIMENSIONS'
4034       include 'COMMON.GEO'
4035       include 'COMMON.VAR'
4036       include 'COMMON.LOCAL'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.DERIV'
4039       include 'COMMON.INTERACT'
4040       include 'COMMON.FFIELD'
4041       include 'COMMON.IOUNITS'
4042       dimension ggg(3)
4043       evdw2=0.0D0
4044       evdw2_14=0.0d0
4045 cd    print '(a)','Enter ESCP'
4046 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4047 c     &  ' scal14',scal14
4048       do i=iatscp_s,iatscp_e
4049         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4050         iteli=itel(i)
4051 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4052 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4053         if (iteli.eq.0) goto 1225
4054         xi=0.5D0*(c(1,i)+c(1,i+1))
4055         yi=0.5D0*(c(2,i)+c(2,i+1))
4056         zi=0.5D0*(c(3,i)+c(3,i+1))
4057 C Returning the ith atom to box
4058           xi=mod(xi,boxxsize)
4059           if (xi.lt.0) xi=xi+boxxsize
4060           yi=mod(yi,boxysize)
4061           if (yi.lt.0) yi=yi+boxysize
4062           zi=mod(zi,boxzsize)
4063           if (zi.lt.0) zi=zi+boxzsize
4064         do iint=1,nscp_gr(i)
4065
4066         do j=iscpstart(i,iint),iscpend(i,iint)
4067           itypj=iabs(itype(j))
4068           if (itypj.eq.ntyp1) cycle
4069 C Uncomment following three lines for SC-p interactions
4070 c         xj=c(1,nres+j)-xi
4071 c         yj=c(2,nres+j)-yi
4072 c         zj=c(3,nres+j)-zi
4073 C Uncomment following three lines for Ca-p interactions
4074           xj=c(1,j)
4075           yj=c(2,j)
4076           zj=c(3,j)
4077 C returning the jth atom to box
4078           xj=mod(xj,boxxsize)
4079           if (xj.lt.0) xj=xj+boxxsize
4080           yj=mod(yj,boxysize)
4081           if (yj.lt.0) yj=yj+boxysize
4082           zj=mod(zj,boxzsize)
4083           if (zj.lt.0) zj=zj+boxzsize
4084       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4085       xj_safe=xj
4086       yj_safe=yj
4087       zj_safe=zj
4088       subchap=0
4089 C Finding the closest jth atom
4090       do xshift=-1,1
4091       do yshift=-1,1
4092       do zshift=-1,1
4093           xj=xj_safe+xshift*boxxsize
4094           yj=yj_safe+yshift*boxysize
4095           zj=zj_safe+zshift*boxzsize
4096           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4097           if(dist_temp.lt.dist_init) then
4098             dist_init=dist_temp
4099             xj_temp=xj
4100             yj_temp=yj
4101             zj_temp=zj
4102             subchap=1
4103           endif
4104        enddo
4105        enddo
4106        enddo
4107        if (subchap.eq.1) then
4108           xj=xj_temp-xi
4109           yj=yj_temp-yi
4110           zj=zj_temp-zi
4111        else
4112           xj=xj_safe-xi
4113           yj=yj_safe-yi
4114           zj=zj_safe-zi
4115        endif
4116           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4117 C sss is scaling function for smoothing the cutoff gradient otherwise
4118 C the gradient would not be continuouse
4119           sss=sscale(1.0d0/(dsqrt(rrij)))
4120           if (sss.le.0.0d0) cycle
4121           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4122           fac=rrij**expon2
4123           e1=fac*fac*aad(itypj,iteli)
4124           e2=fac*bad(itypj,iteli)
4125           if (iabs(j-i) .le. 2) then
4126             e1=scal14*e1
4127             e2=scal14*e2
4128             evdw2_14=evdw2_14+(e1+e2)*sss
4129           endif
4130           evdwij=e1+e2
4131 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4132 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4133 c     &       bad(itypj,iteli)
4134           evdw2=evdw2+evdwij*sss
4135           if (calc_grad) then
4136 C
4137 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4138 C
4139           fac=-(evdwij+e1)*rrij*sss
4140           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4141           ggg(1)=xj*fac
4142           ggg(2)=yj*fac
4143           ggg(3)=zj*fac
4144           if (j.lt.i) then
4145 cd          write (iout,*) 'j<i'
4146 C Uncomment following three lines for SC-p interactions
4147 c           do k=1,3
4148 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4149 c           enddo
4150           else
4151 cd          write (iout,*) 'j>i'
4152             do k=1,3
4153               ggg(k)=-ggg(k)
4154 C Uncomment following line for SC-p interactions
4155 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4156             enddo
4157           endif
4158           do k=1,3
4159             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4160           enddo
4161           kstart=min0(i+1,j)
4162           kend=max0(i-1,j-1)
4163 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4164 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4165           do k=kstart,kend
4166             do l=1,3
4167               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4168             enddo
4169           enddo
4170           endif ! calc_grad
4171         enddo
4172         enddo ! iint
4173  1225   continue
4174       enddo ! i
4175       do i=1,nct
4176         do j=1,3
4177           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4178           gradx_scp(j,i)=expon*gradx_scp(j,i)
4179         enddo
4180       enddo
4181 C******************************************************************************
4182 C
4183 C                              N O T E !!!
4184 C
4185 C To save time the factor EXPON has been extracted from ALL components
4186 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4187 C use!
4188 C
4189 C******************************************************************************
4190       return
4191       end
4192 C--------------------------------------------------------------------------
4193       subroutine edis(ehpb)
4194 C
4195 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4196 C
4197       implicit real*8 (a-h,o-z)
4198       include 'DIMENSIONS'
4199       include 'COMMON.SBRIDGE'
4200       include 'COMMON.CHAIN'
4201       include 'COMMON.DERIV'
4202       include 'COMMON.VAR'
4203       include 'COMMON.INTERACT'
4204       include 'COMMON.CONTROL'
4205       include 'COMMON.IOUNITS'
4206       dimension ggg(3),ggg_peak(3,1000)
4207       ehpb=0.0D0
4208       ggg=0.0d0
4209 c 8/21/18 AL: added explicit restraints on reference coords
4210 c      write (iout,*) "restr_on_coord",restr_on_coord
4211       if (restr_on_coord) then
4212
4213       do i=nnt,nct
4214         ecoor=0.0d0
4215         if (itype(i).eq.ntyp1) cycle
4216         do j=1,3
4217           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4218           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4219         enddo
4220         if (itype(i).ne.10) then
4221           do j=1,3
4222             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4223             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4224           enddo
4225         endif
4226         if (energy_dec) write (iout,*)
4227      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4228         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4229       enddo
4230
4231       endif
4232 C      write (iout,*) ,"link_end",link_end,constr_dist
4233 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4234 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4235 c     &  " constr_dist",constr_dist
4236       if (link_end.eq.0.and.link_end_peak.eq.0) return
4237       do i=link_start_peak,link_end_peak
4238         ehpb_peak=0.0d0
4239 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4240 c     &   ipeak(1,i),ipeak(2,i)
4241         do ip=ipeak(1,i),ipeak(2,i)
4242           ii=ihpb_peak(ip)
4243           jj=jhpb_peak(ip)
4244           dd=dist(ii,jj)
4245           iip=ip-ipeak(1,i)+1
4246 C iii and jjj point to the residues for which the distance is assigned.
4247 c          if (ii.gt.nres) then
4248 c            iii=ii-nres
4249 c            jjj=jj-nres
4250 c          else
4251 c            iii=ii
4252 c            jjj=jj
4253 c          endif
4254           if (ii.gt.nres) then
4255             iii=ii-nres
4256           else
4257             iii=ii
4258           endif
4259           if (jj.gt.nres) then
4260             jjj=jj-nres
4261           else
4262             jjj=jj
4263           endif
4264           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4265           aux=dexp(-scal_peak*aux)
4266           ehpb_peak=ehpb_peak+aux
4267           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4268      &      forcon_peak(ip))*aux/dd
4269           do j=1,3
4270             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4271           enddo
4272           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4273      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4274      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4275         enddo
4276 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4277         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4278         do ip=ipeak(1,i),ipeak(2,i)
4279           iip=ip-ipeak(1,i)+1
4280           do j=1,3
4281             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4282           enddo
4283           ii=ihpb_peak(ip)
4284           jj=jhpb_peak(ip)
4285 C iii and jjj point to the residues for which the distance is assigned.
4286 c          if (ii.gt.nres) then
4287 c            iii=ii-nres
4288 c            jjj=jj-nres
4289 c          else
4290 c            iii=ii
4291 c            jjj=jj
4292 c          endif
4293           if (ii.gt.nres) then
4294             iii=ii-nres
4295           else
4296             iii=ii
4297           endif
4298           if (jj.gt.nres) then
4299             jjj=jj-nres
4300           else
4301             jjj=jj
4302           endif
4303           if (iii.lt.ii) then
4304             do j=1,3
4305               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4306             enddo
4307           endif
4308           if (jjj.lt.jj) then
4309             do j=1,3
4310               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4311             enddo
4312           endif
4313           do k=1,3
4314             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4315             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4316           enddo
4317         enddo
4318       enddo
4319       do i=link_start,link_end
4320 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4321 C CA-CA distance used in regularization of structure.
4322         ii=ihpb(i)
4323         jj=jhpb(i)
4324 C iii and jjj point to the residues for which the distance is assigned.
4325 c        if (ii.gt.nres) then
4326 c          iii=ii-nres
4327 c          jjj=jj-nres
4328 c        else
4329 c          iii=ii
4330 c          jjj=jj
4331 c        endif
4332         if (ii.gt.nres) then
4333           iii=ii-nres
4334         else
4335           iii=ii
4336         endif
4337         if (jj.gt.nres) then
4338           jjj=jj-nres
4339         else
4340           jjj=jj
4341         endif
4342 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4343 c     &    dhpb(i),dhpb1(i),forcon(i)
4344 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4345 C    distance and angle dependent SS bond potential.
4346 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4347 C     & iabs(itype(jjj)).eq.1) then
4348 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4349 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4350         if (.not.dyn_ss .and. i.le.nss) then
4351 C 15/02/13 CC dynamic SSbond - additional check
4352           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4353      &        iabs(itype(jjj)).eq.1) then
4354            call ssbond_ene(iii,jjj,eij)
4355            ehpb=ehpb+2*eij
4356          endif
4357 cd          write (iout,*) "eij",eij
4358 cd   &   ' waga=',waga,' fac=',fac
4359 !        else if (ii.gt.nres .and. jj.gt.nres) then
4360         else
4361 C Calculate the distance between the two points and its difference from the
4362 C target distance.
4363           dd=dist(ii,jj)
4364           if (irestr_type(i).eq.11) then
4365             ehpb=ehpb+fordepth(i)!**4.0d0
4366      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4367             fac=fordepth(i)!**4.0d0
4368      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4369             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4370      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4371      &        ehpb,irestr_type(i)
4372           else if (irestr_type(i).eq.10) then
4373 c AL 6//19/2018 cross-link restraints
4374             xdis = 0.5d0*(dd/forcon(i))**2
4375             expdis = dexp(-xdis)
4376 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4377             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4378 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4379 c     &          " wboltzd",wboltzd
4380             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4381 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4382             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4383      &           *expdis/(aux*forcon(i)**2)
4384             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4385      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4386      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4387           else if (irestr_type(i).eq.2) then
4388 c Quartic restraints
4389             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4390             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4391      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4392      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4393             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4394           else
4395 c Quadratic restraints
4396             rdis=dd-dhpb(i)
4397 C Get the force constant corresponding to this distance.
4398             waga=forcon(i)
4399 C Calculate the contribution to energy.
4400             ehpb=ehpb+0.5d0*waga*rdis*rdis
4401             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4402      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4403      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4404 C
4405 C Evaluate gradient.
4406 C
4407             fac=waga*rdis/dd
4408           endif
4409 c Calculate Cartesian gradient
4410           do j=1,3
4411             ggg(j)=fac*(c(j,jj)-c(j,ii))
4412           enddo
4413 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4414 C If this is a SC-SC distance, we need to calculate the contributions to the
4415 C Cartesian gradient in the SC vectors (ghpbx).
4416           if (iii.lt.ii) then
4417             do j=1,3
4418               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4419             enddo
4420           endif
4421           if (jjj.lt.jj) then
4422             do j=1,3
4423               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4424             enddo
4425           endif
4426           do k=1,3
4427             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4428             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4429           enddo
4430         endif
4431       enddo
4432       return
4433       end
4434 C--------------------------------------------------------------------------
4435       subroutine ssbond_ene(i,j,eij)
4436 C
4437 C Calculate the distance and angle dependent SS-bond potential energy
4438 C using a free-energy function derived based on RHF/6-31G** ab initio
4439 C calculations of diethyl disulfide.
4440 C
4441 C A. Liwo and U. Kozlowska, 11/24/03
4442 C
4443       implicit real*8 (a-h,o-z)
4444       include 'DIMENSIONS'
4445       include 'COMMON.SBRIDGE'
4446       include 'COMMON.CHAIN'
4447       include 'COMMON.DERIV'
4448       include 'COMMON.LOCAL'
4449       include 'COMMON.INTERACT'
4450       include 'COMMON.VAR'
4451       include 'COMMON.IOUNITS'
4452       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4453       itypi=iabs(itype(i))
4454       xi=c(1,nres+i)
4455       yi=c(2,nres+i)
4456       zi=c(3,nres+i)
4457       dxi=dc_norm(1,nres+i)
4458       dyi=dc_norm(2,nres+i)
4459       dzi=dc_norm(3,nres+i)
4460       dsci_inv=dsc_inv(itypi)
4461       itypj=iabs(itype(j))
4462       dscj_inv=dsc_inv(itypj)
4463       xj=c(1,nres+j)-xi
4464       yj=c(2,nres+j)-yi
4465       zj=c(3,nres+j)-zi
4466       dxj=dc_norm(1,nres+j)
4467       dyj=dc_norm(2,nres+j)
4468       dzj=dc_norm(3,nres+j)
4469       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4470       rij=dsqrt(rrij)
4471       erij(1)=xj*rij
4472       erij(2)=yj*rij
4473       erij(3)=zj*rij
4474       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4475       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4476       om12=dxi*dxj+dyi*dyj+dzi*dzj
4477       do k=1,3
4478         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4479         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4480       enddo
4481       rij=1.0d0/rij
4482       deltad=rij-d0cm
4483       deltat1=1.0d0-om1
4484       deltat2=1.0d0+om2
4485       deltat12=om2-om1+2.0d0
4486       cosphi=om12-om1*om2
4487       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4488      &  +akct*deltad*deltat12
4489      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4490 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4491 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4492 c     &  " deltat12",deltat12," eij",eij
4493       ed=2*akcm*deltad+akct*deltat12
4494       pom1=akct*deltad
4495       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4496       eom1=-2*akth*deltat1-pom1-om2*pom2
4497       eom2= 2*akth*deltat2+pom1-om1*pom2
4498       eom12=pom2
4499       do k=1,3
4500         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4501       enddo
4502       do k=1,3
4503         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4504      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4505         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4506      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4507       enddo
4508 C
4509 C Calculate the components of the gradient in DC and X
4510 C
4511       do k=i,j-1
4512         do l=1,3
4513           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4514         enddo
4515       enddo
4516       return
4517       end
4518 C--------------------------------------------------------------------------
4519       subroutine ebond(estr)
4520 c
4521 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4522 c
4523       implicit real*8 (a-h,o-z)
4524       include 'DIMENSIONS'
4525       include 'COMMON.LOCAL'
4526       include 'COMMON.GEO'
4527       include 'COMMON.INTERACT'
4528       include 'COMMON.DERIV'
4529       include 'COMMON.VAR'
4530       include 'COMMON.CHAIN'
4531       include 'COMMON.IOUNITS'
4532       include 'COMMON.NAMES'
4533       include 'COMMON.FFIELD'
4534       include 'COMMON.CONTROL'
4535       double precision u(3),ud(3)
4536       estr=0.0d0
4537       estr1=0.0d0
4538 c      write (iout,*) "distchainmax",distchainmax
4539       do i=nnt+1,nct
4540 #ifdef FIVEDIAG
4541         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
4542         diff = vbld(i)-vbldp0
4543 #else
4544         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4545 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4546 C          do j=1,3
4547 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4548 C     &      *dc(j,i-1)/vbld(i)
4549 C          enddo
4550 C          if (energy_dec) write(iout,*)
4551 C     &       "estr1",i,vbld(i),distchainmax,
4552 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4553 C        else
4554          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4555         diff = vbld(i)-vbldpDUM
4556 C         write(iout,*) i,diff
4557          else
4558           diff = vbld(i)-vbldp0
4559 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4560          endif
4561 #endif
4562         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4563      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4564           estr=estr+diff*diff
4565           do j=1,3
4566             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4567           enddo
4568 C        endif
4569 C        write (iout,'(a7,i5,4f7.3)')
4570 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4571       enddo
4572       estr=0.5d0*AKP*estr+estr1
4573 c
4574 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4575 c
4576       do i=nnt,nct
4577         iti=iabs(itype(i))
4578         if (iti.ne.10 .and. iti.ne.ntyp1) then
4579           nbi=nbondterm(iti)
4580           if (nbi.eq.1) then
4581             diff=vbld(i+nres)-vbldsc0(1,iti)
4582             if (energy_dec) write (iout,*)
4583      &      i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4584      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4585             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4586             do j=1,3
4587               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4588             enddo
4589           else
4590             do j=1,nbi
4591               diff=vbld(i+nres)-vbldsc0(j,iti)
4592               ud(j)=aksc(j,iti)*diff
4593               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4594             enddo
4595             uprod=u(1)
4596             do j=2,nbi
4597               uprod=uprod*u(j)
4598             enddo
4599             usum=0.0d0
4600             usumsqder=0.0d0
4601             do j=1,nbi
4602               uprod1=1.0d0
4603               uprod2=1.0d0
4604               do k=1,nbi
4605                 if (k.ne.j) then
4606                   uprod1=uprod1*u(k)
4607                   uprod2=uprod2*u(k)*u(k)
4608                 endif
4609               enddo
4610               usum=usum+uprod1
4611               usumsqder=usumsqder+ud(j)*uprod2
4612             enddo
4613 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4614 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4615             estr=estr+uprod/usum
4616             do j=1,3
4617              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4618             enddo
4619           endif
4620         endif
4621       enddo
4622       return
4623       end
4624 #ifdef CRYST_THETA
4625 C--------------------------------------------------------------------------
4626       subroutine ebend(etheta,ethetacnstr)
4627 C
4628 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4629 C angles gamma and its derivatives in consecutive thetas and gammas.
4630 C
4631       implicit real*8 (a-h,o-z)
4632       include 'DIMENSIONS'
4633       include 'COMMON.LOCAL'
4634       include 'COMMON.GEO'
4635       include 'COMMON.INTERACT'
4636       include 'COMMON.DERIV'
4637       include 'COMMON.VAR'
4638       include 'COMMON.CHAIN'
4639       include 'COMMON.IOUNITS'
4640       include 'COMMON.NAMES'
4641       include 'COMMON.FFIELD'
4642       include 'COMMON.TORCNSTR'
4643       common /calcthet/ term1,term2,termm,diffak,ratak,
4644      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4645      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4646       double precision y(2),z(2)
4647       delta=0.02d0*pi
4648 c      time11=dexp(-2*time)
4649 c      time12=1.0d0
4650       etheta=0.0D0
4651 c      write (iout,*) "nres",nres
4652 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4653 c      write (iout,*) ithet_start,ithet_end
4654       do i=ithet_start,ithet_end
4655 C        if (itype(i-1).eq.ntyp1) cycle
4656         if (i.le.2) cycle
4657         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4658      &  .or.itype(i).eq.ntyp1) cycle
4659 C Zero the energy function and its derivative at 0 or pi.
4660         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4661         it=itype(i-1)
4662         ichir1=isign(1,itype(i-2))
4663         ichir2=isign(1,itype(i))
4664          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4665          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4666          if (itype(i-1).eq.10) then
4667           itype1=isign(10,itype(i-2))
4668           ichir11=isign(1,itype(i-2))
4669           ichir12=isign(1,itype(i-2))
4670           itype2=isign(10,itype(i))
4671           ichir21=isign(1,itype(i))
4672           ichir22=isign(1,itype(i))
4673          endif
4674          if (i.eq.3) then
4675           y(1)=0.0D0
4676           y(2)=0.0D0
4677           else
4678
4679         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4680 #ifdef OSF
4681           phii=phi(i)
4682 c          icrc=0
4683 c          call proc_proc(phii,icrc)
4684           if (icrc.eq.1) phii=150.0
4685 #else
4686           phii=phi(i)
4687 #endif
4688           y(1)=dcos(phii)
4689           y(2)=dsin(phii)
4690         else
4691           y(1)=0.0D0
4692           y(2)=0.0D0
4693         endif
4694         endif
4695         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4696 #ifdef OSF
4697           phii1=phi(i+1)
4698 c          icrc=0
4699 c          call proc_proc(phii1,icrc)
4700           if (icrc.eq.1) phii1=150.0
4701           phii1=pinorm(phii1)
4702           z(1)=cos(phii1)
4703 #else
4704           phii1=phi(i+1)
4705           z(1)=dcos(phii1)
4706 #endif
4707           z(2)=dsin(phii1)
4708         else
4709           z(1)=0.0D0
4710           z(2)=0.0D0
4711         endif
4712 C Calculate the "mean" value of theta from the part of the distribution
4713 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4714 C In following comments this theta will be referred to as t_c.
4715         thet_pred_mean=0.0d0
4716         do k=1,2
4717             athetk=athet(k,it,ichir1,ichir2)
4718             bthetk=bthet(k,it,ichir1,ichir2)
4719           if (it.eq.10) then
4720              athetk=athet(k,itype1,ichir11,ichir12)
4721              bthetk=bthet(k,itype2,ichir21,ichir22)
4722           endif
4723           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4724         enddo
4725 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4726         dthett=thet_pred_mean*ssd
4727         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4728 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4729 C Derivatives of the "mean" values in gamma1 and gamma2.
4730         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4731      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4732          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4733      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4734          if (it.eq.10) then
4735       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4736      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4737         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4738      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4739          endif
4740         if (theta(i).gt.pi-delta) then
4741           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4742      &         E_tc0)
4743           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4744           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4745           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4746      &        E_theta)
4747           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4748      &        E_tc)
4749         else if (theta(i).lt.delta) then
4750           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4751           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4752           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4753      &        E_theta)
4754           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4755           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4756      &        E_tc)
4757         else
4758           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4759      &        E_theta,E_tc)
4760         endif
4761         etheta=etheta+ethetai
4762 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4763 c     &      'ebend',i,ethetai,theta(i),itype(i)
4764 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4765 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4766         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4767         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4768         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4769 c 1215   continue
4770       enddo
4771       ethetacnstr=0.0d0
4772 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4773       do i=1,ntheta_constr
4774         itheta=itheta_constr(i)
4775         thetiii=theta(itheta)
4776         difi=pinorm(thetiii-theta_constr0(i))
4777         if (difi.gt.theta_drange(i)) then
4778           difi=difi-theta_drange(i)
4779           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4780           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4781      &    +for_thet_constr(i)*difi**3
4782         else if (difi.lt.-drange(i)) then
4783           difi=difi+drange(i)
4784           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4785           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4786      &    +for_thet_constr(i)*difi**3
4787         else
4788           difi=0.0
4789         endif
4790 C       if (energy_dec) then
4791 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4792 C     &    i,itheta,rad2deg*thetiii,
4793 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4794 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4795 C     &    gloc(itheta+nphi-2,icg)
4796 C        endif
4797       enddo
4798 C Ufff.... We've done all this!!!
4799       return
4800       end
4801 C---------------------------------------------------------------------------
4802       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4803      &     E_tc)
4804       implicit real*8 (a-h,o-z)
4805       include 'DIMENSIONS'
4806       include 'COMMON.LOCAL'
4807       include 'COMMON.IOUNITS'
4808       common /calcthet/ term1,term2,termm,diffak,ratak,
4809      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4810      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4811 C Calculate the contributions to both Gaussian lobes.
4812 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4813 C The "polynomial part" of the "standard deviation" of this part of
4814 C the distribution.
4815         sig=polthet(3,it)
4816         do j=2,0,-1
4817           sig=sig*thet_pred_mean+polthet(j,it)
4818         enddo
4819 C Derivative of the "interior part" of the "standard deviation of the"
4820 C gamma-dependent Gaussian lobe in t_c.
4821         sigtc=3*polthet(3,it)
4822         do j=2,1,-1
4823           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4824         enddo
4825         sigtc=sig*sigtc
4826 C Set the parameters of both Gaussian lobes of the distribution.
4827 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4828         fac=sig*sig+sigc0(it)
4829         sigcsq=fac+fac
4830         sigc=1.0D0/sigcsq
4831 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4832         sigsqtc=-4.0D0*sigcsq*sigtc
4833 c       print *,i,sig,sigtc,sigsqtc
4834 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4835         sigtc=-sigtc/(fac*fac)
4836 C Following variable is sigma(t_c)**(-2)
4837         sigcsq=sigcsq*sigcsq
4838         sig0i=sig0(it)
4839         sig0inv=1.0D0/sig0i**2
4840         delthec=thetai-thet_pred_mean
4841         delthe0=thetai-theta0i
4842         term1=-0.5D0*sigcsq*delthec*delthec
4843         term2=-0.5D0*sig0inv*delthe0*delthe0
4844 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4845 C NaNs in taking the logarithm. We extract the largest exponent which is added
4846 C to the energy (this being the log of the distribution) at the end of energy
4847 C term evaluation for this virtual-bond angle.
4848         if (term1.gt.term2) then
4849           termm=term1
4850           term2=dexp(term2-termm)
4851           term1=1.0d0
4852         else
4853           termm=term2
4854           term1=dexp(term1-termm)
4855           term2=1.0d0
4856         endif
4857 C The ratio between the gamma-independent and gamma-dependent lobes of
4858 C the distribution is a Gaussian function of thet_pred_mean too.
4859         diffak=gthet(2,it)-thet_pred_mean
4860         ratak=diffak/gthet(3,it)**2
4861         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4862 C Let's differentiate it in thet_pred_mean NOW.
4863         aktc=ak*ratak
4864 C Now put together the distribution terms to make complete distribution.
4865         termexp=term1+ak*term2
4866         termpre=sigc+ak*sig0i
4867 C Contribution of the bending energy from this theta is just the -log of
4868 C the sum of the contributions from the two lobes and the pre-exponential
4869 C factor. Simple enough, isn't it?
4870         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4871 C NOW the derivatives!!!
4872 C 6/6/97 Take into account the deformation.
4873         E_theta=(delthec*sigcsq*term1
4874      &       +ak*delthe0*sig0inv*term2)/termexp
4875         E_tc=((sigtc+aktc*sig0i)/termpre
4876      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4877      &       aktc*term2)/termexp)
4878       return
4879       end
4880 c-----------------------------------------------------------------------------
4881       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4882       implicit real*8 (a-h,o-z)
4883       include 'DIMENSIONS'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.IOUNITS'
4886       common /calcthet/ term1,term2,termm,diffak,ratak,
4887      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4888      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4889       delthec=thetai-thet_pred_mean
4890       delthe0=thetai-theta0i
4891 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4892       t3 = thetai-thet_pred_mean
4893       t6 = t3**2
4894       t9 = term1
4895       t12 = t3*sigcsq
4896       t14 = t12+t6*sigsqtc
4897       t16 = 1.0d0
4898       t21 = thetai-theta0i
4899       t23 = t21**2
4900       t26 = term2
4901       t27 = t21*t26
4902       t32 = termexp
4903       t40 = t32**2
4904       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4905      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4906      & *(-t12*t9-ak*sig0inv*t27)
4907       return
4908       end
4909 #else
4910 C--------------------------------------------------------------------------
4911       subroutine ebend(etheta)
4912 C
4913 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4914 C angles gamma and its derivatives in consecutive thetas and gammas.
4915 C ab initio-derived potentials from
4916 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4917 C
4918       implicit real*8 (a-h,o-z)
4919       include 'DIMENSIONS'
4920       include 'COMMON.LOCAL'
4921       include 'COMMON.GEO'
4922       include 'COMMON.INTERACT'
4923       include 'COMMON.DERIV'
4924       include 'COMMON.VAR'
4925       include 'COMMON.CHAIN'
4926       include 'COMMON.IOUNITS'
4927       include 'COMMON.NAMES'
4928       include 'COMMON.FFIELD'
4929       include 'COMMON.CONTROL'
4930       include 'COMMON.TORCNSTR'
4931       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4932      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4933      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4934      & sinph1ph2(maxdouble,maxdouble)
4935       logical lprn /.false./, lprn1 /.false./
4936       etheta=0.0D0
4937 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4938       do i=ithet_start,ithet_end
4939 C         if (i.eq.2) cycle
4940 C        if (itype(i-1).eq.ntyp1) cycle
4941         if (i.le.2) cycle
4942         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4943      &  .or.itype(i).eq.ntyp1) cycle
4944         if (iabs(itype(i+1)).eq.20) iblock=2
4945         if (iabs(itype(i+1)).ne.20) iblock=1
4946         dethetai=0.0d0
4947         dephii=0.0d0
4948         dephii1=0.0d0
4949         theti2=0.5d0*theta(i)
4950         ityp2=ithetyp((itype(i-1)))
4951         do k=1,nntheterm
4952           coskt(k)=dcos(k*theti2)
4953           sinkt(k)=dsin(k*theti2)
4954         enddo
4955 cu        if (i.eq.3) then
4956 cu          phii=0.0d0
4957 cu          ityp1=nthetyp+1
4958 cu          do k=1,nsingle
4959 cu            cosph1(k)=0.0d0
4960 cu            sinph1(k)=0.0d0
4961 cu          enddo
4962 cu        else
4963         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4964 #ifdef OSF
4965           phii=phi(i)
4966           if (phii.ne.phii) phii=150.0
4967 #else
4968           phii=phi(i)
4969 #endif
4970           ityp1=ithetyp((itype(i-2)))
4971           do k=1,nsingle
4972             cosph1(k)=dcos(k*phii)
4973             sinph1(k)=dsin(k*phii)
4974           enddo
4975         else
4976           phii=0.0d0
4977 c          ityp1=nthetyp+1
4978           do k=1,nsingle
4979             ityp1=ithetyp((itype(i-2)))
4980             cosph1(k)=0.0d0
4981             sinph1(k)=0.0d0
4982           enddo
4983         endif
4984         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4985 #ifdef OSF
4986           phii1=phi(i+1)
4987           if (phii1.ne.phii1) phii1=150.0
4988           phii1=pinorm(phii1)
4989 #else
4990           phii1=phi(i+1)
4991 #endif
4992           ityp3=ithetyp((itype(i)))
4993           do k=1,nsingle
4994             cosph2(k)=dcos(k*phii1)
4995             sinph2(k)=dsin(k*phii1)
4996           enddo
4997         else
4998           phii1=0.0d0
4999 c          ityp3=nthetyp+1
5000           ityp3=ithetyp((itype(i)))
5001           do k=1,nsingle
5002             cosph2(k)=0.0d0
5003             sinph2(k)=0.0d0
5004           enddo
5005         endif
5006 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5007 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5008 c        call flush(iout)
5009         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5010         do k=1,ndouble
5011           do l=1,k-1
5012             ccl=cosph1(l)*cosph2(k-l)
5013             ssl=sinph1(l)*sinph2(k-l)
5014             scl=sinph1(l)*cosph2(k-l)
5015             csl=cosph1(l)*sinph2(k-l)
5016             cosph1ph2(l,k)=ccl-ssl
5017             cosph1ph2(k,l)=ccl+ssl
5018             sinph1ph2(l,k)=scl+csl
5019             sinph1ph2(k,l)=scl-csl
5020           enddo
5021         enddo
5022         if (lprn) then
5023         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5024      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5025         write (iout,*) "coskt and sinkt"
5026         do k=1,nntheterm
5027           write (iout,*) k,coskt(k),sinkt(k)
5028         enddo
5029         endif
5030         do k=1,ntheterm
5031           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5032           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5033      &      *coskt(k)
5034           if (lprn)
5035      &    write (iout,*) "k",k,"
5036      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5037      &     " ethetai",ethetai
5038         enddo
5039         if (lprn) then
5040         write (iout,*) "cosph and sinph"
5041         do k=1,nsingle
5042           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5043         enddo
5044         write (iout,*) "cosph1ph2 and sinph2ph2"
5045         do k=2,ndouble
5046           do l=1,k-1
5047             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5048      &         sinph1ph2(l,k),sinph1ph2(k,l)
5049           enddo
5050         enddo
5051         write(iout,*) "ethetai",ethetai
5052         endif
5053         do m=1,ntheterm2
5054           do k=1,nsingle
5055             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5056      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5057      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5058      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5059             ethetai=ethetai+sinkt(m)*aux
5060             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5061             dephii=dephii+k*sinkt(m)*(
5062      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5063      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5064             dephii1=dephii1+k*sinkt(m)*(
5065      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5066      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5067             if (lprn)
5068      &      write (iout,*) "m",m," k",k," bbthet",
5069      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5070      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5071      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5072      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5073           enddo
5074         enddo
5075         if (lprn)
5076      &  write(iout,*) "ethetai",ethetai
5077         do m=1,ntheterm3
5078           do k=2,ndouble
5079             do l=1,k-1
5080               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5081      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5082      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5083      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5084               ethetai=ethetai+sinkt(m)*aux
5085               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5086               dephii=dephii+l*sinkt(m)*(
5087      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5088      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5089      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5090      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5091               dephii1=dephii1+(k-l)*sinkt(m)*(
5092      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5093      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5094      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5095      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5096               if (lprn) then
5097               write (iout,*) "m",m," k",k," l",l," ffthet",
5098      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5099      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5100      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5101      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5102      &            " ethetai",ethetai
5103               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5104      &            cosph1ph2(k,l)*sinkt(m),
5105      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5106               endif
5107             enddo
5108           enddo
5109         enddo
5110 10      continue
5111         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5112      &   i,theta(i)*rad2deg,phii*rad2deg,
5113      &   phii1*rad2deg,ethetai
5114         etheta=etheta+ethetai
5115         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5116         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5117 c        gloc(nphi+i-2,icg)=wang*dethetai
5118         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5119       enddo
5120       return
5121       end
5122 #endif
5123 #ifdef CRYST_SC
5124 c-----------------------------------------------------------------------------
5125       subroutine esc(escloc)
5126 C Calculate the local energy of a side chain and its derivatives in the
5127 C corresponding virtual-bond valence angles THETA and the spherical angles
5128 C ALPHA and OMEGA.
5129       implicit real*8 (a-h,o-z)
5130       include 'DIMENSIONS'
5131       include 'COMMON.GEO'
5132       include 'COMMON.LOCAL'
5133       include 'COMMON.VAR'
5134       include 'COMMON.INTERACT'
5135       include 'COMMON.DERIV'
5136       include 'COMMON.CHAIN'
5137       include 'COMMON.IOUNITS'
5138       include 'COMMON.NAMES'
5139       include 'COMMON.FFIELD'
5140       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5141      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5142       common /sccalc/ time11,time12,time112,theti,it,nlobit
5143       delta=0.02d0*pi
5144       escloc=0.0D0
5145 C      write (iout,*) 'ESC'
5146       do i=loc_start,loc_end
5147         it=itype(i)
5148         if (it.eq.ntyp1) cycle
5149         if (it.eq.10) goto 1
5150         nlobit=nlob(iabs(it))
5151 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5152 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5153         theti=theta(i+1)-pipol
5154         x(1)=dtan(theti)
5155         x(2)=alph(i)
5156         x(3)=omeg(i)
5157 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5158
5159         if (x(2).gt.pi-delta) then
5160           xtemp(1)=x(1)
5161           xtemp(2)=pi-delta
5162           xtemp(3)=x(3)
5163           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5164           xtemp(2)=pi
5165           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5166           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5167      &        escloci,dersc(2))
5168           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5169      &        ddersc0(1),dersc(1))
5170           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5171      &        ddersc0(3),dersc(3))
5172           xtemp(2)=pi-delta
5173           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5174           xtemp(2)=pi
5175           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5176           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5177      &            dersc0(2),esclocbi,dersc02)
5178           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5179      &            dersc12,dersc01)
5180           call splinthet(x(2),0.5d0*delta,ss,ssd)
5181           dersc0(1)=dersc01
5182           dersc0(2)=dersc02
5183           dersc0(3)=0.0d0
5184           do k=1,3
5185             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5186           enddo
5187           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5188           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5189      &             esclocbi,ss,ssd
5190           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5191 c         escloci=esclocbi
5192 c         write (iout,*) escloci
5193         else if (x(2).lt.delta) then
5194           xtemp(1)=x(1)
5195           xtemp(2)=delta
5196           xtemp(3)=x(3)
5197           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5198           xtemp(2)=0.0d0
5199           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5200           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5201      &        escloci,dersc(2))
5202           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5203      &        ddersc0(1),dersc(1))
5204           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5205      &        ddersc0(3),dersc(3))
5206           xtemp(2)=delta
5207           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5208           xtemp(2)=0.0d0
5209           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5210           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5211      &            dersc0(2),esclocbi,dersc02)
5212           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5213      &            dersc12,dersc01)
5214           dersc0(1)=dersc01
5215           dersc0(2)=dersc02
5216           dersc0(3)=0.0d0
5217           call splinthet(x(2),0.5d0*delta,ss,ssd)
5218           do k=1,3
5219             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5220           enddo
5221           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5222 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5223 c     &             esclocbi,ss,ssd
5224           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5225 C         write (iout,*) 'i=',i, escloci
5226         else
5227           call enesc(x,escloci,dersc,ddummy,.false.)
5228         endif
5229
5230         escloc=escloc+escloci
5231 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5232             write (iout,'(a6,i5,0pf7.3)')
5233      &     'escloc',i,escloci
5234
5235         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5236      &   wscloc*dersc(1)
5237         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5238         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5239     1   continue
5240       enddo
5241       return
5242       end
5243 C---------------------------------------------------------------------------
5244       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5245       implicit real*8 (a-h,o-z)
5246       include 'DIMENSIONS'
5247       include 'COMMON.GEO'
5248       include 'COMMON.LOCAL'
5249       include 'COMMON.IOUNITS'
5250       common /sccalc/ time11,time12,time112,theti,it,nlobit
5251       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5252       double precision contr(maxlob,-1:1)
5253       logical mixed
5254 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5255         escloc_i=0.0D0
5256         do j=1,3
5257           dersc(j)=0.0D0
5258           if (mixed) ddersc(j)=0.0d0
5259         enddo
5260         x3=x(3)
5261
5262 C Because of periodicity of the dependence of the SC energy in omega we have
5263 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5264 C To avoid underflows, first compute & store the exponents.
5265
5266         do iii=-1,1
5267
5268           x(3)=x3+iii*dwapi
5269
5270           do j=1,nlobit
5271             do k=1,3
5272               z(k)=x(k)-censc(k,j,it)
5273             enddo
5274             do k=1,3
5275               Axk=0.0D0
5276               do l=1,3
5277                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5278               enddo
5279               Ax(k,j,iii)=Axk
5280             enddo
5281             expfac=0.0D0
5282             do k=1,3
5283               expfac=expfac+Ax(k,j,iii)*z(k)
5284             enddo
5285             contr(j,iii)=expfac
5286           enddo ! j
5287
5288         enddo ! iii
5289
5290         x(3)=x3
5291 C As in the case of ebend, we want to avoid underflows in exponentiation and
5292 C subsequent NaNs and INFs in energy calculation.
5293 C Find the largest exponent
5294         emin=contr(1,-1)
5295         do iii=-1,1
5296           do j=1,nlobit
5297             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5298           enddo
5299         enddo
5300         emin=0.5D0*emin
5301 cd      print *,'it=',it,' emin=',emin
5302
5303 C Compute the contribution to SC energy and derivatives
5304         do iii=-1,1
5305
5306           do j=1,nlobit
5307             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5308 cd          print *,'j=',j,' expfac=',expfac
5309             escloc_i=escloc_i+expfac
5310             do k=1,3
5311               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5312             enddo
5313             if (mixed) then
5314               do k=1,3,2
5315                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5316      &            +gaussc(k,2,j,it))*expfac
5317               enddo
5318             endif
5319           enddo
5320
5321         enddo ! iii
5322
5323         dersc(1)=dersc(1)/cos(theti)**2
5324         ddersc(1)=ddersc(1)/cos(theti)**2
5325         ddersc(3)=ddersc(3)
5326
5327         escloci=-(dlog(escloc_i)-emin)
5328         do j=1,3
5329           dersc(j)=dersc(j)/escloc_i
5330         enddo
5331         if (mixed) then
5332           do j=1,3,2
5333             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5334           enddo
5335         endif
5336       return
5337       end
5338 C------------------------------------------------------------------------------
5339       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5340       implicit real*8 (a-h,o-z)
5341       include 'DIMENSIONS'
5342       include 'COMMON.GEO'
5343       include 'COMMON.LOCAL'
5344       include 'COMMON.IOUNITS'
5345       common /sccalc/ time11,time12,time112,theti,it,nlobit
5346       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5347       double precision contr(maxlob)
5348       logical mixed
5349
5350       escloc_i=0.0D0
5351
5352       do j=1,3
5353         dersc(j)=0.0D0
5354       enddo
5355
5356       do j=1,nlobit
5357         do k=1,2
5358           z(k)=x(k)-censc(k,j,it)
5359         enddo
5360         z(3)=dwapi
5361         do k=1,3
5362           Axk=0.0D0
5363           do l=1,3
5364             Axk=Axk+gaussc(l,k,j,it)*z(l)
5365           enddo
5366           Ax(k,j)=Axk
5367         enddo
5368         expfac=0.0D0
5369         do k=1,3
5370           expfac=expfac+Ax(k,j)*z(k)
5371         enddo
5372         contr(j)=expfac
5373       enddo ! j
5374
5375 C As in the case of ebend, we want to avoid underflows in exponentiation and
5376 C subsequent NaNs and INFs in energy calculation.
5377 C Find the largest exponent
5378       emin=contr(1)
5379       do j=1,nlobit
5380         if (emin.gt.contr(j)) emin=contr(j)
5381       enddo
5382       emin=0.5D0*emin
5383
5384 C Compute the contribution to SC energy and derivatives
5385
5386       dersc12=0.0d0
5387       do j=1,nlobit
5388         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5389         escloc_i=escloc_i+expfac
5390         do k=1,2
5391           dersc(k)=dersc(k)+Ax(k,j)*expfac
5392         enddo
5393         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5394      &            +gaussc(1,2,j,it))*expfac
5395         dersc(3)=0.0d0
5396       enddo
5397
5398       dersc(1)=dersc(1)/cos(theti)**2
5399       dersc12=dersc12/cos(theti)**2
5400       escloci=-(dlog(escloc_i)-emin)
5401       do j=1,2
5402         dersc(j)=dersc(j)/escloc_i
5403       enddo
5404       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5405       return
5406       end
5407 #else
5408 c----------------------------------------------------------------------------------
5409       subroutine esc(escloc)
5410 C Calculate the local energy of a side chain and its derivatives in the
5411 C corresponding virtual-bond valence angles THETA and the spherical angles
5412 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5413 C added by Urszula Kozlowska. 07/11/2007
5414 C
5415       implicit real*8 (a-h,o-z)
5416       include 'DIMENSIONS'
5417       include 'COMMON.GEO'
5418       include 'COMMON.LOCAL'
5419       include 'COMMON.VAR'
5420       include 'COMMON.SCROT'
5421       include 'COMMON.INTERACT'
5422       include 'COMMON.DERIV'
5423       include 'COMMON.CHAIN'
5424       include 'COMMON.IOUNITS'
5425       include 'COMMON.NAMES'
5426       include 'COMMON.FFIELD'
5427       include 'COMMON.CONTROL'
5428       include 'COMMON.VECTORS'
5429       double precision x_prime(3),y_prime(3),z_prime(3)
5430      &    , sumene,dsc_i,dp2_i,x(65),
5431      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5432      &    de_dxx,de_dyy,de_dzz,de_dt
5433       double precision s1_t,s1_6_t,s2_t,s2_6_t
5434       double precision
5435      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5436      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5437      & dt_dCi(3),dt_dCi1(3)
5438       common /sccalc/ time11,time12,time112,theti,it,nlobit
5439       delta=0.02d0*pi
5440       escloc=0.0D0
5441       do i=loc_start,loc_end
5442         if (itype(i).eq.ntyp1) cycle
5443         costtab(i+1) =dcos(theta(i+1))
5444         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5445         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5446         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5447         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5448         cosfac=dsqrt(cosfac2)
5449         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5450         sinfac=dsqrt(sinfac2)
5451         it=iabs(itype(i))
5452         if (it.eq.10) goto 1
5453 c
5454 C  Compute the axes of tghe local cartesian coordinates system; store in
5455 c   x_prime, y_prime and z_prime
5456 c
5457         do j=1,3
5458           x_prime(j) = 0.00
5459           y_prime(j) = 0.00
5460           z_prime(j) = 0.00
5461         enddo
5462 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5463 C     &   dc_norm(3,i+nres)
5464         do j = 1,3
5465           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5466           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5467         enddo
5468         do j = 1,3
5469           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5470         enddo
5471 c       write (2,*) "i",i
5472 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5473 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5474 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5475 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5476 c      & " xy",scalar(x_prime(1),y_prime(1)),
5477 c      & " xz",scalar(x_prime(1),z_prime(1)),
5478 c      & " yy",scalar(y_prime(1),y_prime(1)),
5479 c      & " yz",scalar(y_prime(1),z_prime(1)),
5480 c      & " zz",scalar(z_prime(1),z_prime(1))
5481 c
5482 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5483 C to local coordinate system. Store in xx, yy, zz.
5484 c
5485         xx=0.0d0
5486         yy=0.0d0
5487         zz=0.0d0
5488         do j = 1,3
5489           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5490           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5491           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5492         enddo
5493
5494         xxtab(i)=xx
5495         yytab(i)=yy
5496         zztab(i)=zz
5497 C
5498 C Compute the energy of the ith side cbain
5499 C
5500 c        write (2,*) "xx",xx," yy",yy," zz",zz
5501         it=iabs(itype(i))
5502         do j = 1,65
5503           x(j) = sc_parmin(j,it)
5504         enddo
5505 #ifdef CHECK_COORD
5506 Cc diagnostics - remove later
5507         xx1 = dcos(alph(2))
5508         yy1 = dsin(alph(2))*dcos(omeg(2))
5509         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5510         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5511      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5512      &    xx1,yy1,zz1
5513 C,"  --- ", xx_w,yy_w,zz_w
5514 c end diagnostics
5515 #endif
5516         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5517      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5518      &   + x(10)*yy*zz
5519         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5520      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5521      & + x(20)*yy*zz
5522         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5523      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5524      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5525      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5526      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5527      &  +x(40)*xx*yy*zz
5528         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5529      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5530      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5531      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5532      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5533      &  +x(60)*xx*yy*zz
5534         dsc_i   = 0.743d0+x(61)
5535         dp2_i   = 1.9d0+x(62)
5536         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5537      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5538         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5539      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5540         s1=(1+x(63))/(0.1d0 + dscp1)
5541         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5542         s2=(1+x(65))/(0.1d0 + dscp2)
5543         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5544         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5545      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5546 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5547 c     &   sumene4,
5548 c     &   dscp1,dscp2,sumene
5549 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5550         escloc = escloc + sumene
5551 c        write (2,*) "escloc",escloc
5552 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5553 c     &  zz,xx,yy
5554         if (.not. calc_grad) goto 1
5555 #ifdef DEBUG
5556 C
5557 C This section to check the numerical derivatives of the energy of ith side
5558 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5559 C #define DEBUG in the code to turn it on.
5560 C
5561         write (2,*) "sumene               =",sumene
5562         aincr=1.0d-7
5563         xxsave=xx
5564         xx=xx+aincr
5565         write (2,*) xx,yy,zz
5566         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5567         de_dxx_num=(sumenep-sumene)/aincr
5568         xx=xxsave
5569         write (2,*) "xx+ sumene from enesc=",sumenep
5570         yysave=yy
5571         yy=yy+aincr
5572         write (2,*) xx,yy,zz
5573         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5574         de_dyy_num=(sumenep-sumene)/aincr
5575         yy=yysave
5576         write (2,*) "yy+ sumene from enesc=",sumenep
5577         zzsave=zz
5578         zz=zz+aincr
5579         write (2,*) xx,yy,zz
5580         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5581         de_dzz_num=(sumenep-sumene)/aincr
5582         zz=zzsave
5583         write (2,*) "zz+ sumene from enesc=",sumenep
5584         costsave=cost2tab(i+1)
5585         sintsave=sint2tab(i+1)
5586         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5587         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5588         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5589         de_dt_num=(sumenep-sumene)/aincr
5590         write (2,*) " t+ sumene from enesc=",sumenep
5591         cost2tab(i+1)=costsave
5592         sint2tab(i+1)=sintsave
5593 C End of diagnostics section.
5594 #endif
5595 C
5596 C Compute the gradient of esc
5597 C
5598         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5599         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5600         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5601         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5602         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5603         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5604         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5605         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5606         pom1=(sumene3*sint2tab(i+1)+sumene1)
5607      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5608         pom2=(sumene4*cost2tab(i+1)+sumene2)
5609      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5610         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5611         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5612      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5613      &  +x(40)*yy*zz
5614         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5615         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5616      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5617      &  +x(60)*yy*zz
5618         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5619      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5620      &        +(pom1+pom2)*pom_dx
5621 #ifdef DEBUG
5622         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5623 #endif
5624 C
5625         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5626         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5627      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5628      &  +x(40)*xx*zz
5629         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5630         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5631      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5632      &  +x(59)*zz**2 +x(60)*xx*zz
5633         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5634      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5635      &        +(pom1-pom2)*pom_dy
5636 #ifdef DEBUG
5637         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5638 #endif
5639 C
5640         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5641      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5642      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5643      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5644      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5645      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5646      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5647      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5648 #ifdef DEBUG
5649         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5650 #endif
5651 C
5652         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5653      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5654      &  +pom1*pom_dt1+pom2*pom_dt2
5655 #ifdef DEBUG
5656         write(2,*), "de_dt = ", de_dt,de_dt_num
5657 #endif
5658 c
5659 C
5660        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5661        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5662        cosfac2xx=cosfac2*xx
5663        sinfac2yy=sinfac2*yy
5664        do k = 1,3
5665          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5666      &      vbld_inv(i+1)
5667          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5668      &      vbld_inv(i)
5669          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5670          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5671 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5672 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5673 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5674 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5675          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5676          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5677          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5678          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5679          dZZ_Ci1(k)=0.0d0
5680          dZZ_Ci(k)=0.0d0
5681          do j=1,3
5682            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5683      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5684            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5685      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5686          enddo
5687
5688          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5689          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5690          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5691 c
5692          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5693          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5694        enddo
5695
5696        do k=1,3
5697          dXX_Ctab(k,i)=dXX_Ci(k)
5698          dXX_C1tab(k,i)=dXX_Ci1(k)
5699          dYY_Ctab(k,i)=dYY_Ci(k)
5700          dYY_C1tab(k,i)=dYY_Ci1(k)
5701          dZZ_Ctab(k,i)=dZZ_Ci(k)
5702          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5703          dXX_XYZtab(k,i)=dXX_XYZ(k)
5704          dYY_XYZtab(k,i)=dYY_XYZ(k)
5705          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5706        enddo
5707
5708        do k = 1,3
5709 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5710 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5711 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5712 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5713 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5714 c     &    dt_dci(k)
5715 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5716 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5717          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5718      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5719          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5720      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5721          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5722      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5723        enddo
5724 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5725 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5726
5727 C to check gradient call subroutine check_grad
5728
5729     1 continue
5730       enddo
5731       return
5732       end
5733 #endif
5734 c------------------------------------------------------------------------------
5735       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5736 C
5737 C This procedure calculates two-body contact function g(rij) and its derivative:
5738 C
5739 C           eps0ij                                     !       x < -1
5740 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5741 C            0                                         !       x > 1
5742 C
5743 C where x=(rij-r0ij)/delta
5744 C
5745 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5746 C
5747       implicit none
5748       double precision rij,r0ij,eps0ij,fcont,fprimcont
5749       double precision x,x2,x4,delta
5750 c     delta=0.02D0*r0ij
5751 c      delta=0.2D0*r0ij
5752       x=(rij-r0ij)/delta
5753       if (x.lt.-1.0D0) then
5754         fcont=eps0ij
5755         fprimcont=0.0D0
5756       else if (x.le.1.0D0) then
5757         x2=x*x
5758         x4=x2*x2
5759         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5760         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5761       else
5762         fcont=0.0D0
5763         fprimcont=0.0D0
5764       endif
5765       return
5766       end
5767 c------------------------------------------------------------------------------
5768       subroutine splinthet(theti,delta,ss,ssder)
5769       implicit real*8 (a-h,o-z)
5770       include 'DIMENSIONS'
5771       include 'COMMON.VAR'
5772       include 'COMMON.GEO'
5773       thetup=pi-delta
5774       thetlow=delta
5775       if (theti.gt.pipol) then
5776         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5777       else
5778         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5779         ssder=-ssder
5780       endif
5781       return
5782       end
5783 c------------------------------------------------------------------------------
5784       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5785       implicit none
5786       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5787       double precision ksi,ksi2,ksi3,a1,a2,a3
5788       a1=fprim0*delta/(f1-f0)
5789       a2=3.0d0-2.0d0*a1
5790       a3=a1-2.0d0
5791       ksi=(x-x0)/delta
5792       ksi2=ksi*ksi
5793       ksi3=ksi2*ksi
5794       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5795       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5796       return
5797       end
5798 c------------------------------------------------------------------------------
5799       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5800       implicit none
5801       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5802       double precision ksi,ksi2,ksi3,a1,a2,a3
5803       ksi=(x-x0)/delta
5804       ksi2=ksi*ksi
5805       ksi3=ksi2*ksi
5806       a1=fprim0x*delta
5807       a2=3*(f1x-f0x)-2*fprim0x*delta
5808       a3=fprim0x*delta-2*(f1x-f0x)
5809       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5810       return
5811       end
5812 C-----------------------------------------------------------------------------
5813 #ifdef CRYST_TOR
5814 C-----------------------------------------------------------------------------
5815       subroutine etor(etors,fact)
5816       implicit real*8 (a-h,o-z)
5817       include 'DIMENSIONS'
5818       include 'COMMON.VAR'
5819       include 'COMMON.GEO'
5820       include 'COMMON.LOCAL'
5821       include 'COMMON.TORSION'
5822       include 'COMMON.INTERACT'
5823       include 'COMMON.DERIV'
5824       include 'COMMON.CHAIN'
5825       include 'COMMON.NAMES'
5826       include 'COMMON.IOUNITS'
5827       include 'COMMON.FFIELD'
5828       include 'COMMON.TORCNSTR'
5829       logical lprn
5830 C Set lprn=.true. for debugging
5831       lprn=.false.
5832 c      lprn=.true.
5833       etors=0.0D0
5834       do i=iphi_start,iphi_end
5835         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5836      &      .or. itype(i).eq.ntyp1) cycle
5837         itori=itortyp(itype(i-2))
5838         itori1=itortyp(itype(i-1))
5839         phii=phi(i)
5840         gloci=0.0D0
5841 C Proline-Proline pair is a special case...
5842         if (itori.eq.3 .and. itori1.eq.3) then
5843           if (phii.gt.-dwapi3) then
5844             cosphi=dcos(3*phii)
5845             fac=1.0D0/(1.0D0-cosphi)
5846             etorsi=v1(1,3,3)*fac
5847             etorsi=etorsi+etorsi
5848             etors=etors+etorsi-v1(1,3,3)
5849             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5850           endif
5851           do j=1,3
5852             v1ij=v1(j+1,itori,itori1)
5853             v2ij=v2(j+1,itori,itori1)
5854             cosphi=dcos(j*phii)
5855             sinphi=dsin(j*phii)
5856             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5857             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5858           enddo
5859         else
5860           do j=1,nterm_old
5861             v1ij=v1(j,itori,itori1)
5862             v2ij=v2(j,itori,itori1)
5863             cosphi=dcos(j*phii)
5864             sinphi=dsin(j*phii)
5865             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5866             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5867           enddo
5868         endif
5869         if (lprn)
5870      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5871      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5872      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5873         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5874 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5875       enddo
5876       return
5877       end
5878 c------------------------------------------------------------------------------
5879 #else
5880       subroutine etor(etors,fact)
5881       implicit real*8 (a-h,o-z)
5882       include 'DIMENSIONS'
5883       include 'COMMON.VAR'
5884       include 'COMMON.GEO'
5885       include 'COMMON.LOCAL'
5886       include 'COMMON.TORSION'
5887       include 'COMMON.INTERACT'
5888       include 'COMMON.DERIV'
5889       include 'COMMON.CHAIN'
5890       include 'COMMON.NAMES'
5891       include 'COMMON.IOUNITS'
5892       include 'COMMON.FFIELD'
5893       include 'COMMON.TORCNSTR'
5894       logical lprn
5895 C Set lprn=.true. for debugging
5896       lprn=.false.
5897 c      lprn=.true.
5898       etors=0.0D0
5899       do i=iphi_start,iphi_end
5900         if (i.le.2) cycle
5901         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5902      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5903 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5904 C     &       .or. itype(i).eq.ntyp1) cycle
5905         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5906          if (iabs(itype(i)).eq.20) then
5907          iblock=2
5908          else
5909          iblock=1
5910          endif
5911         itori=itortyp(itype(i-2))
5912         itori1=itortyp(itype(i-1))
5913         phii=phi(i)
5914         gloci=0.0D0
5915 C Regular cosine and sine terms
5916         do j=1,nterm(itori,itori1,iblock)
5917           v1ij=v1(j,itori,itori1,iblock)
5918           v2ij=v2(j,itori,itori1,iblock)
5919           cosphi=dcos(j*phii)
5920           sinphi=dsin(j*phii)
5921           etors=etors+v1ij*cosphi+v2ij*sinphi
5922           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5923         enddo
5924 C Lorentz terms
5925 C                         v1
5926 C  E = SUM ----------------------------------- - v1
5927 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5928 C
5929         cosphi=dcos(0.5d0*phii)
5930         sinphi=dsin(0.5d0*phii)
5931         do j=1,nlor(itori,itori1,iblock)
5932           vl1ij=vlor1(j,itori,itori1)
5933           vl2ij=vlor2(j,itori,itori1)
5934           vl3ij=vlor3(j,itori,itori1)
5935           pom=vl2ij*cosphi+vl3ij*sinphi
5936           pom1=1.0d0/(pom*pom+1.0d0)
5937           etors=etors+vl1ij*pom1
5938 c          if (energy_dec) etors_ii=etors_ii+
5939 c     &                vl1ij*pom1
5940           pom=-pom*pom1*pom1
5941           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5942         enddo
5943 C Subtract the constant term
5944         etors=etors-v0(itori,itori1,iblock)
5945         if (lprn)
5946      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5947      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5948      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5949         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5950 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5951  1215   continue
5952       enddo
5953       return
5954       end
5955 c----------------------------------------------------------------------------
5956       subroutine etor_d(etors_d,fact2)
5957 C 6/23/01 Compute double torsional energy
5958       implicit real*8 (a-h,o-z)
5959       include 'DIMENSIONS'
5960       include 'COMMON.VAR'
5961       include 'COMMON.GEO'
5962       include 'COMMON.LOCAL'
5963       include 'COMMON.TORSION'
5964       include 'COMMON.INTERACT'
5965       include 'COMMON.DERIV'
5966       include 'COMMON.CHAIN'
5967       include 'COMMON.NAMES'
5968       include 'COMMON.IOUNITS'
5969       include 'COMMON.FFIELD'
5970       include 'COMMON.TORCNSTR'
5971       logical lprn
5972 C Set lprn=.true. for debugging
5973       lprn=.false.
5974 c     lprn=.true.
5975       etors_d=0.0D0
5976       do i=iphi_start,iphi_end-1
5977         if (i.le.3) cycle
5978 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5979 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5980          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5981      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5982      &  (itype(i+1).eq.ntyp1)) cycle
5983         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5984      &     goto 1215
5985         itori=itortyp(itype(i-2))
5986         itori1=itortyp(itype(i-1))
5987         itori2=itortyp(itype(i))
5988         phii=phi(i)
5989         phii1=phi(i+1)
5990         gloci1=0.0D0
5991         gloci2=0.0D0
5992         iblock=1
5993         if (iabs(itype(i+1)).eq.20) iblock=2
5994 C Regular cosine and sine terms
5995         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5996           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5997           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5998           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5999           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6000           cosphi1=dcos(j*phii)
6001           sinphi1=dsin(j*phii)
6002           cosphi2=dcos(j*phii1)
6003           sinphi2=dsin(j*phii1)
6004           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6005      &     v2cij*cosphi2+v2sij*sinphi2
6006           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6007           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6008         enddo
6009         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6010           do l=1,k-1
6011             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6012             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6013             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6014             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6015             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6016             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6017             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6018             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6019             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6020      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6021             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6022      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6023             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6024      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6025           enddo
6026         enddo
6027         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6028         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6029  1215   continue
6030       enddo
6031       return
6032       end
6033 #endif
6034 c---------------------------------------------------------------------------
6035 C The rigorous attempt to derive energy function
6036       subroutine etor_kcc(etors,fact)
6037       implicit real*8 (a-h,o-z)
6038       include 'DIMENSIONS'
6039       include 'COMMON.VAR'
6040       include 'COMMON.GEO'
6041       include 'COMMON.LOCAL'
6042       include 'COMMON.TORSION'
6043       include 'COMMON.INTERACT'
6044       include 'COMMON.DERIV'
6045       include 'COMMON.CHAIN'
6046       include 'COMMON.NAMES'
6047       include 'COMMON.IOUNITS'
6048       include 'COMMON.FFIELD'
6049       include 'COMMON.TORCNSTR'
6050       include 'COMMON.CONTROL'
6051       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6052       logical lprn
6053 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6054 C Set lprn=.true. for debugging
6055       lprn=energy_dec
6056 c     lprn=.true.
6057 C      print *,"wchodze kcc"
6058       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6059       etors=0.0D0
6060       do i=iphi_start,iphi_end
6061 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6062 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6063 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6064 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6065         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6066      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6067         itori=itortyp(itype(i-2))
6068         itori1=itortyp(itype(i-1))
6069         phii=phi(i)
6070         glocig=0.0D0
6071         glocit1=0.0d0
6072         glocit2=0.0d0
6073 C to avoid multiple devision by 2
6074 c        theti22=0.5d0*theta(i)
6075 C theta 12 is the theta_1 /2
6076 C theta 22 is theta_2 /2
6077 c        theti12=0.5d0*theta(i-1)
6078 C and appropriate sinus function
6079         sinthet1=dsin(theta(i-1))
6080         sinthet2=dsin(theta(i))
6081         costhet1=dcos(theta(i-1))
6082         costhet2=dcos(theta(i))
6083 C to speed up lets store its mutliplication
6084         sint1t2=sinthet2*sinthet1
6085         sint1t2n=1.0d0
6086 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6087 C +d_n*sin(n*gamma)) *
6088 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6089 C we have two sum 1) Non-Chebyshev which is with n and gamma
6090         nval=nterm_kcc_Tb(itori,itori1)
6091         c1(0)=0.0d0
6092         c2(0)=0.0d0
6093         c1(1)=1.0d0
6094         c2(1)=1.0d0
6095         do j=2,nval
6096           c1(j)=c1(j-1)*costhet1
6097           c2(j)=c2(j-1)*costhet2
6098         enddo
6099         etori=0.0d0
6100         do j=1,nterm_kcc(itori,itori1)
6101           cosphi=dcos(j*phii)
6102           sinphi=dsin(j*phii)
6103           sint1t2n1=sint1t2n
6104           sint1t2n=sint1t2n*sint1t2
6105           sumvalc=0.0d0
6106           gradvalct1=0.0d0
6107           gradvalct2=0.0d0
6108           do k=1,nval
6109             do l=1,nval
6110               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6111               gradvalct1=gradvalct1+
6112      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6113               gradvalct2=gradvalct2+
6114      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6115             enddo
6116           enddo
6117           gradvalct1=-gradvalct1*sinthet1
6118           gradvalct2=-gradvalct2*sinthet2
6119           sumvals=0.0d0
6120           gradvalst1=0.0d0
6121           gradvalst2=0.0d0
6122           do k=1,nval
6123             do l=1,nval
6124               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6125               gradvalst1=gradvalst1+
6126      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6127               gradvalst2=gradvalst2+
6128      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6129             enddo
6130           enddo
6131           gradvalst1=-gradvalst1*sinthet1
6132           gradvalst2=-gradvalst2*sinthet2
6133           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6134 C glocig is the gradient local i site in gamma
6135           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6136 C now gradient over theta_1
6137           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6138      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6139           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6140      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6141         enddo ! j
6142         etors=etors+etori
6143 C derivative over gamma
6144         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6145 C derivative over theta1
6146         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6147 C now derivative over theta2
6148         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6149         if (lprn)
6150      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6151      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6152       enddo
6153       return
6154       end
6155 c---------------------------------------------------------------------------------------------
6156       subroutine etor_constr(edihcnstr)
6157       implicit real*8 (a-h,o-z)
6158       include 'DIMENSIONS'
6159       include 'COMMON.VAR'
6160       include 'COMMON.GEO'
6161       include 'COMMON.LOCAL'
6162       include 'COMMON.TORSION'
6163       include 'COMMON.INTERACT'
6164       include 'COMMON.DERIV'
6165       include 'COMMON.CHAIN'
6166       include 'COMMON.NAMES'
6167       include 'COMMON.IOUNITS'
6168       include 'COMMON.FFIELD'
6169       include 'COMMON.TORCNSTR'
6170       include 'COMMON.CONTROL'
6171 ! 6/20/98 - dihedral angle constraints
6172       edihcnstr=0.0d0
6173 c      do i=1,ndih_constr
6174 c      write (iout,*) "idihconstr_start",idihconstr_start,
6175 c     &  " idihconstr_end",idihconstr_end
6176       if (raw_psipred) then
6177         do i=idihconstr_start,idihconstr_end
6178           itori=idih_constr(i)
6179           phii=phi(itori)
6180           gaudih_i=vpsipred(1,i)
6181           gauder_i=0.0d0
6182           do j=1,2
6183             s = sdihed(j,i)
6184             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6185             dexpcos_i=dexp(-cos_i*cos_i)
6186             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6187             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6188      &            *cos_i*dexpcos_i/s**2
6189           enddo
6190           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6191           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6192           if (energy_dec)
6193      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6194      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6195      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6196      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6197      &     -wdihc*dlog(gaudih_i)
6198         enddo
6199       else
6200         do i=idihconstr_start,idihconstr_end
6201           itori=idih_constr(i)
6202           phii=phi(itori)
6203           difi=pinorm(phii-phi0(i))
6204           if (difi.gt.drange(i)) then
6205             difi=difi-drange(i)
6206             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6207             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6208           else if (difi.lt.-drange(i)) then
6209             difi=difi+drange(i)
6210             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6211             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6212           else
6213             difi=0.0
6214           endif
6215         enddo
6216       endif
6217       return
6218       end
6219 c----------------------------------------------------------------------------
6220 C The rigorous attempt to derive energy function
6221       subroutine ebend_kcc(etheta)
6222
6223       implicit real*8 (a-h,o-z)
6224       include 'DIMENSIONS'
6225       include 'COMMON.VAR'
6226       include 'COMMON.GEO'
6227       include 'COMMON.LOCAL'
6228       include 'COMMON.TORSION'
6229       include 'COMMON.INTERACT'
6230       include 'COMMON.DERIV'
6231       include 'COMMON.CHAIN'
6232       include 'COMMON.NAMES'
6233       include 'COMMON.IOUNITS'
6234       include 'COMMON.FFIELD'
6235       include 'COMMON.TORCNSTR'
6236       include 'COMMON.CONTROL'
6237       logical lprn
6238       double precision thybt1(maxang_kcc)
6239 C Set lprn=.true. for debugging
6240       lprn=energy_dec
6241 c     lprn=.true.
6242 C      print *,"wchodze kcc"
6243       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6244       etheta=0.0D0
6245       do i=ithet_start,ithet_end
6246 c        print *,i,itype(i-1),itype(i),itype(i-2)
6247         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6248      &  .or.itype(i).eq.ntyp1) cycle
6249         iti=iabs(itortyp(itype(i-1)))
6250         sinthet=dsin(theta(i))
6251         costhet=dcos(theta(i))
6252         do j=1,nbend_kcc_Tb(iti)
6253           thybt1(j)=v1bend_chyb(j,iti)
6254         enddo
6255         sumth1thyb=v1bend_chyb(0,iti)+
6256      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6257         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6258      &    sumth1thyb
6259         ihelp=nbend_kcc_Tb(iti)-1
6260         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6261         etheta=etheta+sumth1thyb
6262 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6263         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6264       enddo
6265       return
6266       end
6267 c-------------------------------------------------------------------------------------
6268       subroutine etheta_constr(ethetacnstr)
6269
6270       implicit real*8 (a-h,o-z)
6271       include 'DIMENSIONS'
6272       include 'COMMON.VAR'
6273       include 'COMMON.GEO'
6274       include 'COMMON.LOCAL'
6275       include 'COMMON.TORSION'
6276       include 'COMMON.INTERACT'
6277       include 'COMMON.DERIV'
6278       include 'COMMON.CHAIN'
6279       include 'COMMON.NAMES'
6280       include 'COMMON.IOUNITS'
6281       include 'COMMON.FFIELD'
6282       include 'COMMON.TORCNSTR'
6283       include 'COMMON.CONTROL'
6284       ethetacnstr=0.0d0
6285 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6286       do i=ithetaconstr_start,ithetaconstr_end
6287         itheta=itheta_constr(i)
6288         thetiii=theta(itheta)
6289         difi=pinorm(thetiii-theta_constr0(i))
6290         if (difi.gt.theta_drange(i)) then
6291           difi=difi-theta_drange(i)
6292           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6293           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6294      &    +for_thet_constr(i)*difi**3
6295         else if (difi.lt.-drange(i)) then
6296           difi=difi+drange(i)
6297           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6298           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6299      &    +for_thet_constr(i)*difi**3
6300         else
6301           difi=0.0
6302         endif
6303        if (energy_dec) then
6304         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6305      &    i,itheta,rad2deg*thetiii,
6306      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6307      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6308      &    gloc(itheta+nphi-2,icg)
6309         endif
6310       enddo
6311       return
6312       end
6313 c------------------------------------------------------------------------------
6314 c------------------------------------------------------------------------------
6315       subroutine eback_sc_corr(esccor)
6316 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6317 c        conformational states; temporarily implemented as differences
6318 c        between UNRES torsional potentials (dependent on three types of
6319 c        residues) and the torsional potentials dependent on all 20 types
6320 c        of residues computed from AM1 energy surfaces of terminally-blocked
6321 c        amino-acid residues.
6322       implicit real*8 (a-h,o-z)
6323       include 'DIMENSIONS'
6324       include 'COMMON.VAR'
6325       include 'COMMON.GEO'
6326       include 'COMMON.LOCAL'
6327       include 'COMMON.TORSION'
6328       include 'COMMON.SCCOR'
6329       include 'COMMON.INTERACT'
6330       include 'COMMON.DERIV'
6331       include 'COMMON.CHAIN'
6332       include 'COMMON.NAMES'
6333       include 'COMMON.IOUNITS'
6334       include 'COMMON.FFIELD'
6335       include 'COMMON.CONTROL'
6336       logical lprn
6337 C Set lprn=.true. for debugging
6338       lprn=.false.
6339 c      lprn=.true.
6340 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6341       esccor=0.0D0
6342       do i=itau_start,itau_end
6343         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6344         esccor_ii=0.0D0
6345         isccori=isccortyp(itype(i-2))
6346         isccori1=isccortyp(itype(i-1))
6347         phii=phi(i)
6348         do intertyp=1,3 !intertyp
6349 cc Added 09 May 2012 (Adasko)
6350 cc  Intertyp means interaction type of backbone mainchain correlation:
6351 c   1 = SC...Ca...Ca...Ca
6352 c   2 = Ca...Ca...Ca...SC
6353 c   3 = SC...Ca...Ca...SCi
6354         gloci=0.0D0
6355         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6356      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6357      &      (itype(i-1).eq.ntyp1)))
6358      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6359      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6360      &     .or.(itype(i).eq.ntyp1)))
6361      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6362      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6363      &      (itype(i-3).eq.ntyp1)))) cycle
6364         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6365         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6366      & cycle
6367        do j=1,nterm_sccor(isccori,isccori1)
6368           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6369           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6370           cosphi=dcos(j*tauangle(intertyp,i))
6371           sinphi=dsin(j*tauangle(intertyp,i))
6372            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6373            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6374          enddo
6375 C      write (iout,*)"EBACK_SC_COR",esccor,i
6376 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6377 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6378 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6379         if (lprn)
6380      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6381      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6382      &  (v1sccor(j,1,itori,itori1),j=1,6)
6383      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6384 c        gsccor_loc(i-3)=gloci
6385        enddo !intertyp
6386       enddo
6387       return
6388       end
6389 #ifdef FOURBODY
6390 c------------------------------------------------------------------------------
6391       subroutine multibody(ecorr)
6392 C This subroutine calculates multi-body contributions to energy following
6393 C the idea of Skolnick et al. If side chains I and J make a contact and
6394 C at the same time side chains I+1 and J+1 make a contact, an extra
6395 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6396       implicit real*8 (a-h,o-z)
6397       include 'DIMENSIONS'
6398       include 'COMMON.IOUNITS'
6399       include 'COMMON.DERIV'
6400       include 'COMMON.INTERACT'
6401       include 'COMMON.CONTACTS'
6402       include 'COMMON.CONTMAT'
6403       include 'COMMON.CORRMAT'
6404       double precision gx(3),gx1(3)
6405       logical lprn
6406
6407 C Set lprn=.true. for debugging
6408       lprn=.false.
6409
6410       if (lprn) then
6411         write (iout,'(a)') 'Contact function values:'
6412         do i=nnt,nct-2
6413           write (iout,'(i2,20(1x,i2,f10.5))')
6414      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6415         enddo
6416       endif
6417       ecorr=0.0D0
6418       do i=nnt,nct
6419         do j=1,3
6420           gradcorr(j,i)=0.0D0
6421           gradxorr(j,i)=0.0D0
6422         enddo
6423       enddo
6424       do i=nnt,nct-2
6425
6426         DO ISHIFT = 3,4
6427
6428         i1=i+ishift
6429         num_conti=num_cont(i)
6430         num_conti1=num_cont(i1)
6431         do jj=1,num_conti
6432           j=jcont(jj,i)
6433           do kk=1,num_conti1
6434             j1=jcont(kk,i1)
6435             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6436 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6437 cd   &                   ' ishift=',ishift
6438 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6439 C The system gains extra energy.
6440               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6441             endif   ! j1==j+-ishift
6442           enddo     ! kk
6443         enddo       ! jj
6444
6445         ENDDO ! ISHIFT
6446
6447       enddo         ! i
6448       return
6449       end
6450 c------------------------------------------------------------------------------
6451       double precision function esccorr(i,j,k,l,jj,kk)
6452       implicit real*8 (a-h,o-z)
6453       include 'DIMENSIONS'
6454       include 'COMMON.IOUNITS'
6455       include 'COMMON.DERIV'
6456       include 'COMMON.INTERACT'
6457       include 'COMMON.CONTACTS'
6458       include 'COMMON.CONTMAT'
6459       include 'COMMON.CORRMAT'
6460       double precision gx(3),gx1(3)
6461       logical lprn
6462       lprn=.false.
6463       eij=facont(jj,i)
6464       ekl=facont(kk,k)
6465 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6466 C Calculate the multi-body contribution to energy.
6467 C Calculate multi-body contributions to the gradient.
6468 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6469 cd   & k,l,(gacont(m,kk,k),m=1,3)
6470       do m=1,3
6471         gx(m) =ekl*gacont(m,jj,i)
6472         gx1(m)=eij*gacont(m,kk,k)
6473         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6474         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6475         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6476         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6477       enddo
6478       do m=i,j-1
6479         do ll=1,3
6480           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6481         enddo
6482       enddo
6483       do m=k,l-1
6484         do ll=1,3
6485           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6486         enddo
6487       enddo
6488       esccorr=-eij*ekl
6489       return
6490       end
6491 c------------------------------------------------------------------------------
6492       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6493 C This subroutine calculates multi-body contributions to hydrogen-bonding
6494       implicit real*8 (a-h,o-z)
6495       include 'DIMENSIONS'
6496       include 'COMMON.IOUNITS'
6497       include 'COMMON.FFIELD'
6498       include 'COMMON.DERIV'
6499       include 'COMMON.INTERACT'
6500       include 'COMMON.CONTACTS'
6501       include 'COMMON.CONTMAT'
6502       include 'COMMON.CORRMAT'
6503       double precision gx(3),gx1(3)
6504       logical lprn,ldone
6505
6506 C Set lprn=.true. for debugging
6507       lprn=.false.
6508       if (lprn) then
6509         write (iout,'(a)') 'Contact function values:'
6510         do i=nnt,nct-2
6511           write (iout,'(2i3,50(1x,i2,f5.2))')
6512      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6513      &    j=1,num_cont_hb(i))
6514         enddo
6515       endif
6516       ecorr=0.0D0
6517 C Remove the loop below after debugging !!!
6518       do i=nnt,nct
6519         do j=1,3
6520           gradcorr(j,i)=0.0D0
6521           gradxorr(j,i)=0.0D0
6522         enddo
6523       enddo
6524 C Calculate the local-electrostatic correlation terms
6525       do i=iatel_s,iatel_e+1
6526         i1=i+1
6527         num_conti=num_cont_hb(i)
6528         num_conti1=num_cont_hb(i+1)
6529         do jj=1,num_conti
6530           j=jcont_hb(jj,i)
6531           do kk=1,num_conti1
6532             j1=jcont_hb(kk,i1)
6533 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6534 c     &         ' jj=',jj,' kk=',kk
6535             if (j1.eq.j+1 .or. j1.eq.j-1) then
6536 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6537 C The system gains extra energy.
6538               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6539               n_corr=n_corr+1
6540             else if (j1.eq.j) then
6541 C Contacts I-J and I-(J+1) occur simultaneously.
6542 C The system loses extra energy.
6543 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6544             endif
6545           enddo ! kk
6546           do kk=1,num_conti
6547             j1=jcont_hb(kk,i)
6548 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6549 c    &         ' jj=',jj,' kk=',kk
6550             if (j1.eq.j+1) then
6551 C Contacts I-J and (I+1)-J occur simultaneously.
6552 C The system loses extra energy.
6553 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6554             endif ! j1==j+1
6555           enddo ! kk
6556         enddo ! jj
6557       enddo ! i
6558       return
6559       end
6560 c------------------------------------------------------------------------------
6561       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6562      &  n_corr1)
6563 C This subroutine calculates multi-body contributions to hydrogen-bonding
6564       implicit real*8 (a-h,o-z)
6565       include 'DIMENSIONS'
6566       include 'COMMON.IOUNITS'
6567 #ifdef MPI
6568       include "mpif.h"
6569 #endif
6570       include 'COMMON.FFIELD'
6571       include 'COMMON.DERIV'
6572       include 'COMMON.LOCAL'
6573       include 'COMMON.INTERACT'
6574       include 'COMMON.CONTACTS'
6575       include 'COMMON.CONTMAT'
6576       include 'COMMON.CORRMAT'
6577       include 'COMMON.CHAIN'
6578       include 'COMMON.CONTROL'
6579       include 'COMMON.SHIELD'
6580       double precision gx(3),gx1(3)
6581       integer num_cont_hb_old(maxres)
6582       logical lprn,ldone
6583       double precision eello4,eello5,eelo6,eello_turn6
6584       external eello4,eello5,eello6,eello_turn6
6585 C Set lprn=.true. for debugging
6586       lprn=.false.
6587       eturn6=0.0d0
6588       if (lprn) then
6589         write (iout,'(a)') 'Contact function values:'
6590         do i=nnt,nct-2
6591           write (iout,'(2i3,50(1x,i2,5f6.3))')
6592      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6593      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6594         enddo
6595       endif
6596       ecorr=0.0D0
6597       ecorr5=0.0d0
6598       ecorr6=0.0d0
6599 C Remove the loop below after debugging !!!
6600       do i=nnt,nct
6601         do j=1,3
6602           gradcorr(j,i)=0.0D0
6603           gradxorr(j,i)=0.0D0
6604         enddo
6605       enddo
6606 C Calculate the dipole-dipole interaction energies
6607       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6608       do i=iatel_s,iatel_e+1
6609         num_conti=num_cont_hb(i)
6610         do jj=1,num_conti
6611           j=jcont_hb(jj,i)
6612 #ifdef MOMENT
6613           call dipole(i,j,jj)
6614 #endif
6615         enddo
6616       enddo
6617       endif
6618 C Calculate the local-electrostatic correlation terms
6619 c                write (iout,*) "gradcorr5 in eello5 before loop"
6620 c                do iii=1,nres
6621 c                  write (iout,'(i5,3f10.5)')
6622 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6623 c                enddo
6624       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6625 c        write (iout,*) "corr loop i",i
6626         i1=i+1
6627         num_conti=num_cont_hb(i)
6628         num_conti1=num_cont_hb(i+1)
6629         do jj=1,num_conti
6630           j=jcont_hb(jj,i)
6631           jp=iabs(j)
6632           do kk=1,num_conti1
6633             j1=jcont_hb(kk,i1)
6634             jp1=iabs(j1)
6635 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6636 c     &         ' jj=',jj,' kk=',kk
6637 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6638             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6639      &          .or. j.lt.0 .and. j1.gt.0) .and.
6640      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6641 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6642 C The system gains extra energy.
6643               n_corr=n_corr+1
6644               sqd1=dsqrt(d_cont(jj,i))
6645               sqd2=dsqrt(d_cont(kk,i1))
6646               sred_geom = sqd1*sqd2
6647               IF (sred_geom.lt.cutoff_corr) THEN
6648                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6649      &            ekont,fprimcont)
6650 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6651 cd     &         ' jj=',jj,' kk=',kk
6652                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6653                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6654                 do l=1,3
6655                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6656                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6657                 enddo
6658                 n_corr1=n_corr1+1
6659 cd               write (iout,*) 'sred_geom=',sred_geom,
6660 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6661 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6662 cd               write (iout,*) "g_contij",g_contij
6663 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6664 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6665                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6666                 if (wcorr4.gt.0.0d0)
6667      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6668 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6669                   if (energy_dec.and.wcorr4.gt.0.0d0)
6670      1                 write (iout,'(a6,4i5,0pf7.3)')
6671      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6672 c                write (iout,*) "gradcorr5 before eello5"
6673 c                do iii=1,nres
6674 c                  write (iout,'(i5,3f10.5)')
6675 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6676 c                enddo
6677                 if (wcorr5.gt.0.0d0)
6678      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6679 c                write (iout,*) "gradcorr5 after eello5"
6680 c                do iii=1,nres
6681 c                  write (iout,'(i5,3f10.5)')
6682 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6683 c                enddo
6684                   if (energy_dec.and.wcorr5.gt.0.0d0)
6685      1                 write (iout,'(a6,4i5,0pf7.3)')
6686      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6687 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6688 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6689                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6690      &               .or. wturn6.eq.0.0d0))then
6691 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6692                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6693                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6694      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6695 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6696 cd     &            'ecorr6=',ecorr6
6697 cd                write (iout,'(4e15.5)') sred_geom,
6698 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6699 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6700 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6701                 else if (wturn6.gt.0.0d0
6702      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6703 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6704                   eturn6=eturn6+eello_turn6(i,jj,kk)
6705                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6706      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6707 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6708                 endif
6709               ENDIF
6710 1111          continue
6711             endif
6712           enddo ! kk
6713         enddo ! jj
6714       enddo ! i
6715       do i=1,nres
6716         num_cont_hb(i)=num_cont_hb_old(i)
6717       enddo
6718 c                write (iout,*) "gradcorr5 in eello5"
6719 c                do iii=1,nres
6720 c                  write (iout,'(i5,3f10.5)')
6721 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6722 c                enddo
6723       return
6724       end
6725 c------------------------------------------------------------------------------
6726       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6727       implicit real*8 (a-h,o-z)
6728       include 'DIMENSIONS'
6729       include 'COMMON.IOUNITS'
6730       include 'COMMON.DERIV'
6731       include 'COMMON.INTERACT'
6732       include 'COMMON.CONTACTS'
6733       include 'COMMON.CONTMAT'
6734       include 'COMMON.CORRMAT'
6735       include 'COMMON.SHIELD'
6736       include 'COMMON.CONTROL'
6737       double precision gx(3),gx1(3)
6738       logical lprn
6739       lprn=.false.
6740 C      print *,"wchodze",fac_shield(i),shield_mode
6741       eij=facont_hb(jj,i)
6742       ekl=facont_hb(kk,k)
6743       ees0pij=ees0p(jj,i)
6744       ees0pkl=ees0p(kk,k)
6745       ees0mij=ees0m(jj,i)
6746       ees0mkl=ees0m(kk,k)
6747       ekont=eij*ekl
6748       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6749 C*
6750 C     & fac_shield(i)**2*fac_shield(j)**2
6751 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6752 C Following 4 lines for diagnostics.
6753 cd    ees0pkl=0.0D0
6754 cd    ees0pij=1.0D0
6755 cd    ees0mkl=0.0D0
6756 cd    ees0mij=1.0D0
6757 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6758 c     & 'Contacts ',i,j,
6759 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6760 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6761 c     & 'gradcorr_long'
6762 C Calculate the multi-body contribution to energy.
6763 C      ecorr=ecorr+ekont*ees
6764 C Calculate multi-body contributions to the gradient.
6765       coeffpees0pij=coeffp*ees0pij
6766       coeffmees0mij=coeffm*ees0mij
6767       coeffpees0pkl=coeffp*ees0pkl
6768       coeffmees0mkl=coeffm*ees0mkl
6769       do ll=1,3
6770 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6771         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6772      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6773      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6774         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6775      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6776      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6777 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6778         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6779      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6780      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6781         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6782      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6783      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6784         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6785      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6786      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6787         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6788         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6789         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6790      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6791      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6792         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6793         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6794 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6795       enddo
6796 c      write (iout,*)
6797 cgrad      do m=i+1,j-1
6798 cgrad        do ll=1,3
6799 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6800 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6801 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6802 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6803 cgrad        enddo
6804 cgrad      enddo
6805 cgrad      do m=k+1,l-1
6806 cgrad        do ll=1,3
6807 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6808 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6809 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6810 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6811 cgrad        enddo
6812 cgrad      enddo
6813 c      write (iout,*) "ehbcorr",ekont*ees
6814 C      print *,ekont,ees,i,k
6815       ehbcorr=ekont*ees
6816 C now gradient over shielding
6817 C      return
6818       if (shield_mode.gt.0) then
6819        j=ees0plist(jj,i)
6820        l=ees0plist(kk,k)
6821 C        print *,i,j,fac_shield(i),fac_shield(j),
6822 C     &fac_shield(k),fac_shield(l)
6823         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6824      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6825           do ilist=1,ishield_list(i)
6826            iresshield=shield_list(ilist,i)
6827            do m=1,3
6828            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6829 C     &      *2.0
6830            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6831      &              rlocshield
6832      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6833             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6834      &+rlocshield
6835            enddo
6836           enddo
6837           do ilist=1,ishield_list(j)
6838            iresshield=shield_list(ilist,j)
6839            do m=1,3
6840            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6841 C     &     *2.0
6842            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6843      &              rlocshield
6844      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6845            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6846      &     +rlocshield
6847            enddo
6848           enddo
6849
6850           do ilist=1,ishield_list(k)
6851            iresshield=shield_list(ilist,k)
6852            do m=1,3
6853            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6854 C     &     *2.0
6855            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6856      &              rlocshield
6857      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6858            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6859      &     +rlocshield
6860            enddo
6861           enddo
6862           do ilist=1,ishield_list(l)
6863            iresshield=shield_list(ilist,l)
6864            do m=1,3
6865            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6866 C     &     *2.0
6867            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6868      &              rlocshield
6869      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6870            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6871      &     +rlocshield
6872            enddo
6873           enddo
6874 C          print *,gshieldx(m,iresshield)
6875           do m=1,3
6876             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6877      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6878             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6879      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6880             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6881      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6882             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6883      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6884
6885             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6886      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6887             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6888      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6889             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6890      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6891             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6892      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6893
6894            enddo
6895       endif
6896       endif
6897       return
6898       end
6899 #ifdef MOMENT
6900 C---------------------------------------------------------------------------
6901       subroutine dipole(i,j,jj)
6902       implicit real*8 (a-h,o-z)
6903       include 'DIMENSIONS'
6904       include 'COMMON.IOUNITS'
6905       include 'COMMON.CHAIN'
6906       include 'COMMON.FFIELD'
6907       include 'COMMON.DERIV'
6908       include 'COMMON.INTERACT'
6909       include 'COMMON.CONTACTS'
6910       include 'COMMON.CONTMAT'
6911       include 'COMMON.CORRMAT'
6912       include 'COMMON.TORSION'
6913       include 'COMMON.VAR'
6914       include 'COMMON.GEO'
6915       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6916      &  auxmat(2,2)
6917       iti1 = itortyp(itype(i+1))
6918       if (j.lt.nres-1) then
6919         itj1 = itype2loc(itype(j+1))
6920       else
6921         itj1=nloctyp
6922       endif
6923       do iii=1,2
6924         dipi(iii,1)=Ub2(iii,i)
6925         dipderi(iii)=Ub2der(iii,i)
6926         dipi(iii,2)=b1(iii,i+1)
6927         dipj(iii,1)=Ub2(iii,j)
6928         dipderj(iii)=Ub2der(iii,j)
6929         dipj(iii,2)=b1(iii,j+1)
6930       enddo
6931       kkk=0
6932       do iii=1,2
6933         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6934         do jjj=1,2
6935           kkk=kkk+1
6936           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6937         enddo
6938       enddo
6939       do kkk=1,5
6940         do lll=1,3
6941           mmm=0
6942           do iii=1,2
6943             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6944      &        auxvec(1))
6945             do jjj=1,2
6946               mmm=mmm+1
6947               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6948             enddo
6949           enddo
6950         enddo
6951       enddo
6952       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6953       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6954       do iii=1,2
6955         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6956       enddo
6957       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6958       do iii=1,2
6959         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6960       enddo
6961       return
6962       end
6963 #endif
6964 C---------------------------------------------------------------------------
6965       subroutine calc_eello(i,j,k,l,jj,kk)
6966 C
6967 C This subroutine computes matrices and vectors needed to calculate
6968 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6969 C
6970       implicit real*8 (a-h,o-z)
6971       include 'DIMENSIONS'
6972       include 'COMMON.IOUNITS'
6973       include 'COMMON.CHAIN'
6974       include 'COMMON.DERIV'
6975       include 'COMMON.INTERACT'
6976       include 'COMMON.CONTACTS'
6977       include 'COMMON.CONTMAT'
6978       include 'COMMON.CORRMAT'
6979       include 'COMMON.TORSION'
6980       include 'COMMON.VAR'
6981       include 'COMMON.GEO'
6982       include 'COMMON.FFIELD'
6983       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6984      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6985       logical lprn
6986       common /kutas/ lprn
6987 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6988 cd     & ' jj=',jj,' kk=',kk
6989 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6990 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6991 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6992       do iii=1,2
6993         do jjj=1,2
6994           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6995           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6996         enddo
6997       enddo
6998       call transpose2(aa1(1,1),aa1t(1,1))
6999       call transpose2(aa2(1,1),aa2t(1,1))
7000       do kkk=1,5
7001         do lll=1,3
7002           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7003      &      aa1tder(1,1,lll,kkk))
7004           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7005      &      aa2tder(1,1,lll,kkk))
7006         enddo
7007       enddo
7008       if (l.eq.j+1) then
7009 C parallel orientation of the two CA-CA-CA frames.
7010         if (i.gt.1) then
7011           iti=itype2loc(itype(i))
7012         else
7013           iti=nloctyp
7014         endif
7015         itk1=itype2loc(itype(k+1))
7016         itj=itype2loc(itype(j))
7017         if (l.lt.nres-1) then
7018           itl1=itype2loc(itype(l+1))
7019         else
7020           itl1=nloctyp
7021         endif
7022 C A1 kernel(j+1) A2T
7023 cd        do iii=1,2
7024 cd          write (iout,'(3f10.5,5x,3f10.5)')
7025 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7026 cd        enddo
7027         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7028      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7029      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7030 C Following matrices are needed only for 6-th order cumulants
7031         IF (wcorr6.gt.0.0d0) THEN
7032         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7033      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7034      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7035         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7036      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7037      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7038      &   ADtEAderx(1,1,1,1,1,1))
7039         lprn=.false.
7040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7041      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7042      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7043      &   ADtEA1derx(1,1,1,1,1,1))
7044         ENDIF
7045 C End 6-th order cumulants
7046 cd        lprn=.false.
7047 cd        if (lprn) then
7048 cd        write (2,*) 'In calc_eello6'
7049 cd        do iii=1,2
7050 cd          write (2,*) 'iii=',iii
7051 cd          do kkk=1,5
7052 cd            write (2,*) 'kkk=',kkk
7053 cd            do jjj=1,2
7054 cd              write (2,'(3(2f10.5),5x)')
7055 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7056 cd            enddo
7057 cd          enddo
7058 cd        enddo
7059 cd        endif
7060         call transpose2(EUgder(1,1,k),auxmat(1,1))
7061         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7062         call transpose2(EUg(1,1,k),auxmat(1,1))
7063         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7064         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7065         do iii=1,2
7066           do kkk=1,5
7067             do lll=1,3
7068               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7069      &          EAEAderx(1,1,lll,kkk,iii,1))
7070             enddo
7071           enddo
7072         enddo
7073 C A1T kernel(i+1) A2
7074         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7075      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7076      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7077 C Following matrices are needed only for 6-th order cumulants
7078         IF (wcorr6.gt.0.0d0) THEN
7079         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7080      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7081      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7082         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7083      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7084      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7085      &   ADtEAderx(1,1,1,1,1,2))
7086         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7087      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7088      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7089      &   ADtEA1derx(1,1,1,1,1,2))
7090         ENDIF
7091 C End 6-th order cumulants
7092         call transpose2(EUgder(1,1,l),auxmat(1,1))
7093         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7094         call transpose2(EUg(1,1,l),auxmat(1,1))
7095         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7096         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7097         do iii=1,2
7098           do kkk=1,5
7099             do lll=1,3
7100               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7101      &          EAEAderx(1,1,lll,kkk,iii,2))
7102             enddo
7103           enddo
7104         enddo
7105 C AEAb1 and AEAb2
7106 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7107 C They are needed only when the fifth- or the sixth-order cumulants are
7108 C indluded.
7109         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7110         call transpose2(AEA(1,1,1),auxmat(1,1))
7111         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7112         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7113         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7114         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7115         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7116         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7117         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7118         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7119         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7120         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7121         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7122         call transpose2(AEA(1,1,2),auxmat(1,1))
7123         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7124         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7125         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7126         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7127         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7128         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7129         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7130         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7131         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7132         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7133         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7134 C Calculate the Cartesian derivatives of the vectors.
7135         do iii=1,2
7136           do kkk=1,5
7137             do lll=1,3
7138               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7139               call matvec2(auxmat(1,1),b1(1,i),
7140      &          AEAb1derx(1,lll,kkk,iii,1,1))
7141               call matvec2(auxmat(1,1),Ub2(1,i),
7142      &          AEAb2derx(1,lll,kkk,iii,1,1))
7143               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7144      &          AEAb1derx(1,lll,kkk,iii,2,1))
7145               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7146      &          AEAb2derx(1,lll,kkk,iii,2,1))
7147               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7148               call matvec2(auxmat(1,1),b1(1,j),
7149      &          AEAb1derx(1,lll,kkk,iii,1,2))
7150               call matvec2(auxmat(1,1),Ub2(1,j),
7151      &          AEAb2derx(1,lll,kkk,iii,1,2))
7152               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7153      &          AEAb1derx(1,lll,kkk,iii,2,2))
7154               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7155      &          AEAb2derx(1,lll,kkk,iii,2,2))
7156             enddo
7157           enddo
7158         enddo
7159         ENDIF
7160 C End vectors
7161       else
7162 C Antiparallel orientation of the two CA-CA-CA frames.
7163         if (i.gt.1) then
7164           iti=itype2loc(itype(i))
7165         else
7166           iti=nloctyp
7167         endif
7168         itk1=itype2loc(itype(k+1))
7169         itl=itype2loc(itype(l))
7170         itj=itype2loc(itype(j))
7171         if (j.lt.nres-1) then
7172           itj1=itype2loc(itype(j+1))
7173         else
7174           itj1=nloctyp
7175         endif
7176 C A2 kernel(j-1)T A1T
7177         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7178      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7179      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7180 C Following matrices are needed only for 6-th order cumulants
7181         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7182      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7183         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7184      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7185      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7186         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7187      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7188      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7189      &   ADtEAderx(1,1,1,1,1,1))
7190         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7191      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7192      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7193      &   ADtEA1derx(1,1,1,1,1,1))
7194         ENDIF
7195 C End 6-th order cumulants
7196         call transpose2(EUgder(1,1,k),auxmat(1,1))
7197         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7198         call transpose2(EUg(1,1,k),auxmat(1,1))
7199         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7200         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7201         do iii=1,2
7202           do kkk=1,5
7203             do lll=1,3
7204               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7205      &          EAEAderx(1,1,lll,kkk,iii,1))
7206             enddo
7207           enddo
7208         enddo
7209 C A2T kernel(i+1)T A1
7210         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7211      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7212      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7213 C Following matrices are needed only for 6-th order cumulants
7214         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7215      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7216         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7217      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7218      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7220      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7221      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7222      &   ADtEAderx(1,1,1,1,1,2))
7223         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7224      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7225      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7226      &   ADtEA1derx(1,1,1,1,1,2))
7227         ENDIF
7228 C End 6-th order cumulants
7229         call transpose2(EUgder(1,1,j),auxmat(1,1))
7230         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7231         call transpose2(EUg(1,1,j),auxmat(1,1))
7232         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7233         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7234         do iii=1,2
7235           do kkk=1,5
7236             do lll=1,3
7237               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7238      &          EAEAderx(1,1,lll,kkk,iii,2))
7239             enddo
7240           enddo
7241         enddo
7242 C AEAb1 and AEAb2
7243 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7244 C They are needed only when the fifth- or the sixth-order cumulants are
7245 C indluded.
7246         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7247      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7248         call transpose2(AEA(1,1,1),auxmat(1,1))
7249         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7250         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7251         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7252         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7253         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7254         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7255         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7256         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7257         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7258         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7259         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7260         call transpose2(AEA(1,1,2),auxmat(1,1))
7261         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7262         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7263         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7264         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7265         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7266         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7267         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7268         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7269         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7270         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7271         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7272 C Calculate the Cartesian derivatives of the vectors.
7273         do iii=1,2
7274           do kkk=1,5
7275             do lll=1,3
7276               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7277               call matvec2(auxmat(1,1),b1(1,i),
7278      &          AEAb1derx(1,lll,kkk,iii,1,1))
7279               call matvec2(auxmat(1,1),Ub2(1,i),
7280      &          AEAb2derx(1,lll,kkk,iii,1,1))
7281               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7282      &          AEAb1derx(1,lll,kkk,iii,2,1))
7283               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7284      &          AEAb2derx(1,lll,kkk,iii,2,1))
7285               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7286               call matvec2(auxmat(1,1),b1(1,l),
7287      &          AEAb1derx(1,lll,kkk,iii,1,2))
7288               call matvec2(auxmat(1,1),Ub2(1,l),
7289      &          AEAb2derx(1,lll,kkk,iii,1,2))
7290               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7291      &          AEAb1derx(1,lll,kkk,iii,2,2))
7292               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7293      &          AEAb2derx(1,lll,kkk,iii,2,2))
7294             enddo
7295           enddo
7296         enddo
7297         ENDIF
7298 C End vectors
7299       endif
7300       return
7301       end
7302 C---------------------------------------------------------------------------
7303       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7304      &  KK,KKderg,AKA,AKAderg,AKAderx)
7305       implicit none
7306       integer nderg
7307       logical transp
7308       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7309      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7310      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7311       integer iii,kkk,lll
7312       integer jjj,mmm
7313       logical lprn
7314       common /kutas/ lprn
7315       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7316       do iii=1,nderg
7317         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7318      &    AKAderg(1,1,iii))
7319       enddo
7320 cd      if (lprn) write (2,*) 'In kernel'
7321       do kkk=1,5
7322 cd        if (lprn) write (2,*) 'kkk=',kkk
7323         do lll=1,3
7324           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7325      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7326 cd          if (lprn) then
7327 cd            write (2,*) 'lll=',lll
7328 cd            write (2,*) 'iii=1'
7329 cd            do jjj=1,2
7330 cd              write (2,'(3(2f10.5),5x)')
7331 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7332 cd            enddo
7333 cd          endif
7334           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7335      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7336 cd          if (lprn) then
7337 cd            write (2,*) 'lll=',lll
7338 cd            write (2,*) 'iii=2'
7339 cd            do jjj=1,2
7340 cd              write (2,'(3(2f10.5),5x)')
7341 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7342 cd            enddo
7343 cd          endif
7344         enddo
7345       enddo
7346       return
7347       end
7348 C---------------------------------------------------------------------------
7349       double precision function eello4(i,j,k,l,jj,kk)
7350       implicit real*8 (a-h,o-z)
7351       include 'DIMENSIONS'
7352       include 'COMMON.IOUNITS'
7353       include 'COMMON.CHAIN'
7354       include 'COMMON.DERIV'
7355       include 'COMMON.INTERACT'
7356       include 'COMMON.CONTACTS'
7357       include 'COMMON.CONTMAT'
7358       include 'COMMON.CORRMAT'
7359       include 'COMMON.TORSION'
7360       include 'COMMON.VAR'
7361       include 'COMMON.GEO'
7362       double precision pizda(2,2),ggg1(3),ggg2(3)
7363 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7364 cd        eello4=0.0d0
7365 cd        return
7366 cd      endif
7367 cd      print *,'eello4:',i,j,k,l,jj,kk
7368 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7369 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7370 cold      eij=facont_hb(jj,i)
7371 cold      ekl=facont_hb(kk,k)
7372 cold      ekont=eij*ekl
7373       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7374       if (calc_grad) then
7375 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7376       gcorr_loc(k-1)=gcorr_loc(k-1)
7377      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7378       if (l.eq.j+1) then
7379         gcorr_loc(l-1)=gcorr_loc(l-1)
7380      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7381       else
7382         gcorr_loc(j-1)=gcorr_loc(j-1)
7383      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7384       endif
7385       do iii=1,2
7386         do kkk=1,5
7387           do lll=1,3
7388             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7389      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7390 cd            derx(lll,kkk,iii)=0.0d0
7391           enddo
7392         enddo
7393       enddo
7394 cd      gcorr_loc(l-1)=0.0d0
7395 cd      gcorr_loc(j-1)=0.0d0
7396 cd      gcorr_loc(k-1)=0.0d0
7397 cd      eel4=1.0d0
7398 cd      write (iout,*)'Contacts have occurred for peptide groups',
7399 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7400 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7401       if (j.lt.nres-1) then
7402         j1=j+1
7403         j2=j-1
7404       else
7405         j1=j-1
7406         j2=j-2
7407       endif
7408       if (l.lt.nres-1) then
7409         l1=l+1
7410         l2=l-1
7411       else
7412         l1=l-1
7413         l2=l-2
7414       endif
7415       do ll=1,3
7416 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7417 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7418         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7419         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7420 cgrad        ghalf=0.5d0*ggg1(ll)
7421         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7422         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7423         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7424         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7425         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7426         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7427 cgrad        ghalf=0.5d0*ggg2(ll)
7428         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7429         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7430         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7431         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7432         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7433         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7434       enddo
7435 cgrad      do m=i+1,j-1
7436 cgrad        do ll=1,3
7437 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7438 cgrad        enddo
7439 cgrad      enddo
7440 cgrad      do m=k+1,l-1
7441 cgrad        do ll=1,3
7442 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7443 cgrad        enddo
7444 cgrad      enddo
7445 cgrad      do m=i+2,j2
7446 cgrad        do ll=1,3
7447 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7448 cgrad        enddo
7449 cgrad      enddo
7450 cgrad      do m=k+2,l2
7451 cgrad        do ll=1,3
7452 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7453 cgrad        enddo
7454 cgrad      enddo
7455 cd      do iii=1,nres-3
7456 cd        write (2,*) iii,gcorr_loc(iii)
7457 cd      enddo
7458       endif ! calc_grad
7459       eello4=ekont*eel4
7460 cd      write (2,*) 'ekont',ekont
7461 cd      write (iout,*) 'eello4',ekont*eel4
7462       return
7463       end
7464 C---------------------------------------------------------------------------
7465       double precision function eello5(i,j,k,l,jj,kk)
7466       implicit real*8 (a-h,o-z)
7467       include 'DIMENSIONS'
7468       include 'COMMON.IOUNITS'
7469       include 'COMMON.CHAIN'
7470       include 'COMMON.DERIV'
7471       include 'COMMON.INTERACT'
7472       include 'COMMON.CONTACTS'
7473       include 'COMMON.CONTMAT'
7474       include 'COMMON.CORRMAT'
7475       include 'COMMON.TORSION'
7476       include 'COMMON.VAR'
7477       include 'COMMON.GEO'
7478       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7479       double precision ggg1(3),ggg2(3)
7480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7481 C                                                                              C
7482 C                            Parallel chains                                   C
7483 C                                                                              C
7484 C          o             o                   o             o                   C
7485 C         /l\           / \             \   / \           / \   /              C
7486 C        /   \         /   \             \ /   \         /   \ /               C
7487 C       j| o |l1       | o |              o| o |         | o |o                C
7488 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7489 C      \i/   \         /   \ /             /   \         /   \                 C
7490 C       o    k1             o                                                  C
7491 C         (I)          (II)                (III)          (IV)                 C
7492 C                                                                              C
7493 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7494 C                                                                              C
7495 C                            Antiparallel chains                               C
7496 C                                                                              C
7497 C          o             o                   o             o                   C
7498 C         /j\           / \             \   / \           / \   /              C
7499 C        /   \         /   \             \ /   \         /   \ /               C
7500 C      j1| o |l        | o |              o| o |         | o |o                C
7501 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7502 C      \i/   \         /   \ /             /   \         /   \                 C
7503 C       o     k1            o                                                  C
7504 C         (I)          (II)                (III)          (IV)                 C
7505 C                                                                              C
7506 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7507 C                                                                              C
7508 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7509 C                                                                              C
7510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7511 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7512 cd        eello5=0.0d0
7513 cd        return
7514 cd      endif
7515 cd      write (iout,*)
7516 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7517 cd     &   ' and',k,l
7518       itk=itype2loc(itype(k))
7519       itl=itype2loc(itype(l))
7520       itj=itype2loc(itype(j))
7521       eello5_1=0.0d0
7522       eello5_2=0.0d0
7523       eello5_3=0.0d0
7524       eello5_4=0.0d0
7525 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7526 cd     &   eel5_3_num,eel5_4_num)
7527       do iii=1,2
7528         do kkk=1,5
7529           do lll=1,3
7530             derx(lll,kkk,iii)=0.0d0
7531           enddo
7532         enddo
7533       enddo
7534 cd      eij=facont_hb(jj,i)
7535 cd      ekl=facont_hb(kk,k)
7536 cd      ekont=eij*ekl
7537 cd      write (iout,*)'Contacts have occurred for peptide groups',
7538 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7539 cd      goto 1111
7540 C Contribution from the graph I.
7541 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7542 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7543       call transpose2(EUg(1,1,k),auxmat(1,1))
7544       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7545       vv(1)=pizda(1,1)-pizda(2,2)
7546       vv(2)=pizda(1,2)+pizda(2,1)
7547       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7548      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7549       if (calc_grad) then
7550 C Explicit gradient in virtual-dihedral angles.
7551       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7552      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7553      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7554       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7555       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7556       vv(1)=pizda(1,1)-pizda(2,2)
7557       vv(2)=pizda(1,2)+pizda(2,1)
7558       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7559      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7560      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7561       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7562       vv(1)=pizda(1,1)-pizda(2,2)
7563       vv(2)=pizda(1,2)+pizda(2,1)
7564       if (l.eq.j+1) then
7565         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7566      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7567      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7568       else
7569         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7570      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7571      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7572       endif
7573 C Cartesian gradient
7574       do iii=1,2
7575         do kkk=1,5
7576           do lll=1,3
7577             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7578      &        pizda(1,1))
7579             vv(1)=pizda(1,1)-pizda(2,2)
7580             vv(2)=pizda(1,2)+pizda(2,1)
7581             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7582      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7583      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7584           enddo
7585         enddo
7586       enddo
7587       endif ! calc_grad
7588 c      goto 1112
7589 c1111  continue
7590 C Contribution from graph II
7591       call transpose2(EE(1,1,k),auxmat(1,1))
7592       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7593       vv(1)=pizda(1,1)+pizda(2,2)
7594       vv(2)=pizda(2,1)-pizda(1,2)
7595       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7596      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7597       if (calc_grad) then
7598 C Explicit gradient in virtual-dihedral angles.
7599       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7600      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7601       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7602       vv(1)=pizda(1,1)+pizda(2,2)
7603       vv(2)=pizda(2,1)-pizda(1,2)
7604       if (l.eq.j+1) then
7605         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7606      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7607      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7608       else
7609         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7610      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7611      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7612       endif
7613 C Cartesian gradient
7614       do iii=1,2
7615         do kkk=1,5
7616           do lll=1,3
7617             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7618      &        pizda(1,1))
7619             vv(1)=pizda(1,1)+pizda(2,2)
7620             vv(2)=pizda(2,1)-pizda(1,2)
7621             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7622      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7623      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7624           enddo
7625         enddo
7626       enddo
7627       endif ! calc_grad
7628 cd      goto 1112
7629 cd1111  continue
7630       if (l.eq.j+1) then
7631 cd        goto 1110
7632 C Parallel orientation
7633 C Contribution from graph III
7634         call transpose2(EUg(1,1,l),auxmat(1,1))
7635         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7636         vv(1)=pizda(1,1)-pizda(2,2)
7637         vv(2)=pizda(1,2)+pizda(2,1)
7638         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7639      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7640         if (calc_grad) then
7641 C Explicit gradient in virtual-dihedral angles.
7642         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7643      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7644      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7645         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7646         vv(1)=pizda(1,1)-pizda(2,2)
7647         vv(2)=pizda(1,2)+pizda(2,1)
7648         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7649      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7651         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7652         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7653         vv(1)=pizda(1,1)-pizda(2,2)
7654         vv(2)=pizda(1,2)+pizda(2,1)
7655         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7656      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7657      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7658 C Cartesian gradient
7659         do iii=1,2
7660           do kkk=1,5
7661             do lll=1,3
7662               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7663      &          pizda(1,1))
7664               vv(1)=pizda(1,1)-pizda(2,2)
7665               vv(2)=pizda(1,2)+pizda(2,1)
7666               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7667      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7668      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7669             enddo
7670           enddo
7671         enddo
7672 cd        goto 1112
7673 C Contribution from graph IV
7674 cd1110    continue
7675         call transpose2(EE(1,1,l),auxmat(1,1))
7676         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7677         vv(1)=pizda(1,1)+pizda(2,2)
7678         vv(2)=pizda(2,1)-pizda(1,2)
7679         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7680      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7681 C Explicit gradient in virtual-dihedral angles.
7682         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7683      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7684         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7685         vv(1)=pizda(1,1)+pizda(2,2)
7686         vv(2)=pizda(2,1)-pizda(1,2)
7687         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7688      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7689      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7690 C Cartesian gradient
7691         do iii=1,2
7692           do kkk=1,5
7693             do lll=1,3
7694               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7695      &          pizda(1,1))
7696               vv(1)=pizda(1,1)+pizda(2,2)
7697               vv(2)=pizda(2,1)-pizda(1,2)
7698               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7699      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7700      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7701             enddo
7702           enddo
7703         enddo
7704         endif ! calc_grad
7705       else
7706 C Antiparallel orientation
7707 C Contribution from graph III
7708 c        goto 1110
7709         call transpose2(EUg(1,1,j),auxmat(1,1))
7710         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7711         vv(1)=pizda(1,1)-pizda(2,2)
7712         vv(2)=pizda(1,2)+pizda(2,1)
7713         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7715         if (calc_grad) then
7716 C Explicit gradient in virtual-dihedral angles.
7717         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7718      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7720         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7724      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7726         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7727         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7728         vv(1)=pizda(1,1)-pizda(2,2)
7729         vv(2)=pizda(1,2)+pizda(2,1)
7730         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7731      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7732      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7733 C Cartesian gradient
7734         do iii=1,2
7735           do kkk=1,5
7736             do lll=1,3
7737               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7738      &          pizda(1,1))
7739               vv(1)=pizda(1,1)-pizda(2,2)
7740               vv(2)=pizda(1,2)+pizda(2,1)
7741               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7742      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7743      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7744             enddo
7745           enddo
7746         enddo
7747         endif ! calc_grad
7748 cd        goto 1112
7749 C Contribution from graph IV
7750 1110    continue
7751         call transpose2(EE(1,1,j),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7756      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7757         if (calc_grad) then
7758 C Explicit gradient in virtual-dihedral angles.
7759         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7760      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7761         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7762         vv(1)=pizda(1,1)+pizda(2,2)
7763         vv(2)=pizda(2,1)-pizda(1,2)
7764         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7765      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7766      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7767 C Cartesian gradient
7768         do iii=1,2
7769           do kkk=1,5
7770             do lll=1,3
7771               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7772      &          pizda(1,1))
7773               vv(1)=pizda(1,1)+pizda(2,2)
7774               vv(2)=pizda(2,1)-pizda(1,2)
7775               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7776      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7777      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7778             enddo
7779           enddo
7780         enddo
7781         endif ! calc_grad
7782       endif
7783 1112  continue
7784       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7785 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7786 cd        write (2,*) 'ijkl',i,j,k,l
7787 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7788 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7789 cd      endif
7790 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7791 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7792 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7793 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7794       if (calc_grad) then
7795       if (j.lt.nres-1) then
7796         j1=j+1
7797         j2=j-1
7798       else
7799         j1=j-1
7800         j2=j-2
7801       endif
7802       if (l.lt.nres-1) then
7803         l1=l+1
7804         l2=l-1
7805       else
7806         l1=l-1
7807         l2=l-2
7808       endif
7809 cd      eij=1.0d0
7810 cd      ekl=1.0d0
7811 cd      ekont=1.0d0
7812 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7813 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7814 C        summed up outside the subrouine as for the other subroutines
7815 C        handling long-range interactions. The old code is commented out
7816 C        with "cgrad" to keep track of changes.
7817       do ll=1,3
7818 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7819 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7820         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7821         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7822 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7823 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7824 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7825 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7826 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7827 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7828 c     &   gradcorr5ij,
7829 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7830 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7831 cgrad        ghalf=0.5d0*ggg1(ll)
7832 cd        ghalf=0.0d0
7833         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7834         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7835         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7836         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7837         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7838         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7839 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7840 cgrad        ghalf=0.5d0*ggg2(ll)
7841 cd        ghalf=0.0d0
7842         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7843         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7844         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7845         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7846         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7847         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7848       enddo
7849       endif ! calc_grad
7850 cd      goto 1112
7851 cgrad      do m=i+1,j-1
7852 cgrad        do ll=1,3
7853 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7854 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7855 cgrad        enddo
7856 cgrad      enddo
7857 cgrad      do m=k+1,l-1
7858 cgrad        do ll=1,3
7859 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7860 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7861 cgrad        enddo
7862 cgrad      enddo
7863 c1112  continue
7864 cgrad      do m=i+2,j2
7865 cgrad        do ll=1,3
7866 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7867 cgrad        enddo
7868 cgrad      enddo
7869 cgrad      do m=k+2,l2
7870 cgrad        do ll=1,3
7871 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7872 cgrad        enddo
7873 cgrad      enddo
7874 cd      do iii=1,nres-3
7875 cd        write (2,*) iii,g_corr5_loc(iii)
7876 cd      enddo
7877       eello5=ekont*eel5
7878 cd      write (2,*) 'ekont',ekont
7879 cd      write (iout,*) 'eello5',ekont*eel5
7880       return
7881       end
7882 c--------------------------------------------------------------------------
7883       double precision function eello6(i,j,k,l,jj,kk)
7884       implicit real*8 (a-h,o-z)
7885       include 'DIMENSIONS'
7886       include 'COMMON.IOUNITS'
7887       include 'COMMON.CHAIN'
7888       include 'COMMON.DERIV'
7889       include 'COMMON.INTERACT'
7890       include 'COMMON.CONTACTS'
7891       include 'COMMON.CONTMAT'
7892       include 'COMMON.CORRMAT'
7893       include 'COMMON.TORSION'
7894       include 'COMMON.VAR'
7895       include 'COMMON.GEO'
7896       include 'COMMON.FFIELD'
7897       double precision ggg1(3),ggg2(3)
7898 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7899 cd        eello6=0.0d0
7900 cd        return
7901 cd      endif
7902 cd      write (iout,*)
7903 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7904 cd     &   ' and',k,l
7905       eello6_1=0.0d0
7906       eello6_2=0.0d0
7907       eello6_3=0.0d0
7908       eello6_4=0.0d0
7909       eello6_5=0.0d0
7910       eello6_6=0.0d0
7911 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7912 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7913       do iii=1,2
7914         do kkk=1,5
7915           do lll=1,3
7916             derx(lll,kkk,iii)=0.0d0
7917           enddo
7918         enddo
7919       enddo
7920 cd      eij=facont_hb(jj,i)
7921 cd      ekl=facont_hb(kk,k)
7922 cd      ekont=eij*ekl
7923 cd      eij=1.0d0
7924 cd      ekl=1.0d0
7925 cd      ekont=1.0d0
7926       if (l.eq.j+1) then
7927         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7928         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7929         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7930         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7931         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7932         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7933       else
7934         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7935         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7936         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7937         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7938         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7939           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7940         else
7941           eello6_5=0.0d0
7942         endif
7943         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7944       endif
7945 C If turn contributions are considered, they will be handled separately.
7946       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7947 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7948 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7949 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7950 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7951 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7952 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7953 cd      goto 1112
7954       if (calc_grad) then
7955       if (j.lt.nres-1) then
7956         j1=j+1
7957         j2=j-1
7958       else
7959         j1=j-1
7960         j2=j-2
7961       endif
7962       if (l.lt.nres-1) then
7963         l1=l+1
7964         l2=l-1
7965       else
7966         l1=l-1
7967         l2=l-2
7968       endif
7969       do ll=1,3
7970 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7971 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7972 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7973 cgrad        ghalf=0.5d0*ggg1(ll)
7974 cd        ghalf=0.0d0
7975         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7976         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7977         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7978         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7979         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7980         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7981         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7982         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7983 cgrad        ghalf=0.5d0*ggg2(ll)
7984 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7985 cd        ghalf=0.0d0
7986         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7987         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7988         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7989         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7990         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7991         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7992       enddo
7993       endif ! calc_grad
7994 cd      goto 1112
7995 cgrad      do m=i+1,j-1
7996 cgrad        do ll=1,3
7997 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7998 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7999 cgrad        enddo
8000 cgrad      enddo
8001 cgrad      do m=k+1,l-1
8002 cgrad        do ll=1,3
8003 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8004 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8005 cgrad        enddo
8006 cgrad      enddo
8007 cgrad1112  continue
8008 cgrad      do m=i+2,j2
8009 cgrad        do ll=1,3
8010 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cgrad      do m=k+2,l2
8014 cgrad        do ll=1,3
8015 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8016 cgrad        enddo
8017 cgrad      enddo
8018 cd      do iii=1,nres-3
8019 cd        write (2,*) iii,g_corr6_loc(iii)
8020 cd      enddo
8021       eello6=ekont*eel6
8022 cd      write (2,*) 'ekont',ekont
8023 cd      write (iout,*) 'eello6',ekont*eel6
8024       return
8025       end
8026 c--------------------------------------------------------------------------
8027       double precision function eello6_graph1(i,j,k,l,imat,swap)
8028       implicit real*8 (a-h,o-z)
8029       include 'DIMENSIONS'
8030       include 'COMMON.IOUNITS'
8031       include 'COMMON.CHAIN'
8032       include 'COMMON.DERIV'
8033       include 'COMMON.INTERACT'
8034       include 'COMMON.CONTACTS'
8035       include 'COMMON.CONTMAT'
8036       include 'COMMON.CORRMAT'
8037       include 'COMMON.TORSION'
8038       include 'COMMON.VAR'
8039       include 'COMMON.GEO'
8040       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8041       logical swap
8042       logical lprn
8043       common /kutas/ lprn
8044 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8045 C                                                                              C
8046 C      Parallel       Antiparallel                                             C
8047 C                                                                              C
8048 C          o             o                                                     C
8049 C         /l\           /j\                                                    C
8050 C        /   \         /   \                                                   C
8051 C       /| o |         | o |\                                                  C
8052 C     \ j|/k\|  /   \  |/k\|l /                                                C
8053 C      \ /   \ /     \ /   \ /                                                 C
8054 C       o     o       o     o                                                  C
8055 C       i             i                                                        C
8056 C                                                                              C
8057 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8058       itk=itype2loc(itype(k))
8059       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8060       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8061       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8062       call transpose2(EUgC(1,1,k),auxmat(1,1))
8063       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8064       vv1(1)=pizda1(1,1)-pizda1(2,2)
8065       vv1(2)=pizda1(1,2)+pizda1(2,1)
8066       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8067       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8068       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8069       s5=scalar2(vv(1),Dtobr2(1,i))
8070 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8071       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8072       if (calc_grad) then
8073       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8074      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8075      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8076      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8077      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8078      & +scalar2(vv(1),Dtobr2der(1,i)))
8079       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8080       vv1(1)=pizda1(1,1)-pizda1(2,2)
8081       vv1(2)=pizda1(1,2)+pizda1(2,1)
8082       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8083       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8084       if (l.eq.j+1) then
8085         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8086      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8087      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8088      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8089      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8090       else
8091         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8092      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8093      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8094      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8095      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8096       endif
8097       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8098       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8099       vv1(1)=pizda1(1,1)-pizda1(2,2)
8100       vv1(2)=pizda1(1,2)+pizda1(2,1)
8101       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8102      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8103      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8104      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8105       do iii=1,2
8106         if (swap) then
8107           ind=3-iii
8108         else
8109           ind=iii
8110         endif
8111         do kkk=1,5
8112           do lll=1,3
8113             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8114             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8115             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8116             call transpose2(EUgC(1,1,k),auxmat(1,1))
8117             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8118      &        pizda1(1,1))
8119             vv1(1)=pizda1(1,1)-pizda1(2,2)
8120             vv1(2)=pizda1(1,2)+pizda1(2,1)
8121             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8122             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8123      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8124             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8125      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8126             s5=scalar2(vv(1),Dtobr2(1,i))
8127             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8128           enddo
8129         enddo
8130       enddo
8131       endif ! calc_grad
8132       return
8133       end
8134 c----------------------------------------------------------------------------
8135       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8136       implicit real*8 (a-h,o-z)
8137       include 'DIMENSIONS'
8138       include 'COMMON.IOUNITS'
8139       include 'COMMON.CHAIN'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       include 'COMMON.CONTMAT'
8144       include 'COMMON.CORRMAT'
8145       include 'COMMON.TORSION'
8146       include 'COMMON.VAR'
8147       include 'COMMON.GEO'
8148       logical swap
8149       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8150      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8151       logical lprn
8152       common /kutas/ lprn
8153 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8154 C                                                                              C
8155 C      Parallel       Antiparallel                                             C
8156 C                                                                              C
8157 C          o             o                                                     C
8158 C     \   /l\           /j\   /                                                C
8159 C      \ /   \         /   \ /                                                 C
8160 C       o| o |         | o |o                                                  C
8161 C     \ j|/k\|      \  |/k\|l                                                  C
8162 C      \ /   \       \ /   \                                                   C
8163 C       o             o                                                        C
8164 C       i             i                                                        C
8165 C                                                                              C
8166 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8167 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8168 C AL 7/4/01 s1 would occur in the sixth-order moment,
8169 C           but not in a cluster cumulant
8170 #ifdef MOMENT
8171       s1=dip(1,jj,i)*dip(1,kk,k)
8172 #endif
8173       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8174       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8175       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8176       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8177       call transpose2(EUg(1,1,k),auxmat(1,1))
8178       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8179       vv(1)=pizda(1,1)-pizda(2,2)
8180       vv(2)=pizda(1,2)+pizda(2,1)
8181       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8182 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8183 #ifdef MOMENT
8184       eello6_graph2=-(s1+s2+s3+s4)
8185 #else
8186       eello6_graph2=-(s2+s3+s4)
8187 #endif
8188 c      eello6_graph2=-s3
8189 C Derivatives in gamma(i-1)
8190       if (calc_grad) then
8191       if (i.gt.1) then
8192 #ifdef MOMENT
8193         s1=dipderg(1,jj,i)*dip(1,kk,k)
8194 #endif
8195         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8196         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8197         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8198         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8199 #ifdef MOMENT
8200         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8201 #else
8202         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8203 #endif
8204 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8205       endif
8206 C Derivatives in gamma(k-1)
8207 #ifdef MOMENT
8208       s1=dip(1,jj,i)*dipderg(1,kk,k)
8209 #endif
8210       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8211       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8212       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8213       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8214       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8215       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8216       vv(1)=pizda(1,1)-pizda(2,2)
8217       vv(2)=pizda(1,2)+pizda(2,1)
8218       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8219 #ifdef MOMENT
8220       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8221 #else
8222       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8223 #endif
8224 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8225 C Derivatives in gamma(j-1) or gamma(l-1)
8226       if (j.gt.1) then
8227 #ifdef MOMENT
8228         s1=dipderg(3,jj,i)*dip(1,kk,k)
8229 #endif
8230         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8231         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8232         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8233         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8234         vv(1)=pizda(1,1)-pizda(2,2)
8235         vv(2)=pizda(1,2)+pizda(2,1)
8236         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8237 #ifdef MOMENT
8238         if (swap) then
8239           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8240         else
8241           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8242         endif
8243 #endif
8244         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8245 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8246       endif
8247 C Derivatives in gamma(l-1) or gamma(j-1)
8248       if (l.gt.1) then
8249 #ifdef MOMENT
8250         s1=dip(1,jj,i)*dipderg(3,kk,k)
8251 #endif
8252         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8253         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8254         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8255         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8256         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8257         vv(1)=pizda(1,1)-pizda(2,2)
8258         vv(2)=pizda(1,2)+pizda(2,1)
8259         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8260 #ifdef MOMENT
8261         if (swap) then
8262           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8263         else
8264           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8265         endif
8266 #endif
8267         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8268 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8269       endif
8270 C Cartesian derivatives.
8271       if (lprn) then
8272         write (2,*) 'In eello6_graph2'
8273         do iii=1,2
8274           write (2,*) 'iii=',iii
8275           do kkk=1,5
8276             write (2,*) 'kkk=',kkk
8277             do jjj=1,2
8278               write (2,'(3(2f10.5),5x)')
8279      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8280             enddo
8281           enddo
8282         enddo
8283       endif
8284       do iii=1,2
8285         do kkk=1,5
8286           do lll=1,3
8287 #ifdef MOMENT
8288             if (iii.eq.1) then
8289               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8290             else
8291               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8292             endif
8293 #endif
8294             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8295      &        auxvec(1))
8296             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8297             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8298      &        auxvec(1))
8299             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8300             call transpose2(EUg(1,1,k),auxmat(1,1))
8301             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8302      &        pizda(1,1))
8303             vv(1)=pizda(1,1)-pizda(2,2)
8304             vv(2)=pizda(1,2)+pizda(2,1)
8305             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8306 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8307 #ifdef MOMENT
8308             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8309 #else
8310             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8311 #endif
8312             if (swap) then
8313               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8314             else
8315               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8316             endif
8317           enddo
8318         enddo
8319       enddo
8320       endif ! calc_grad
8321       return
8322       end
8323 c----------------------------------------------------------------------------
8324       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8325       implicit real*8 (a-h,o-z)
8326       include 'DIMENSIONS'
8327       include 'COMMON.IOUNITS'
8328       include 'COMMON.CHAIN'
8329       include 'COMMON.DERIV'
8330       include 'COMMON.INTERACT'
8331       include 'COMMON.CONTACTS'
8332       include 'COMMON.CONTMAT'
8333       include 'COMMON.CORRMAT'
8334       include 'COMMON.TORSION'
8335       include 'COMMON.VAR'
8336       include 'COMMON.GEO'
8337       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8338       logical swap
8339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8340 C                                                                              C
8341 C      Parallel       Antiparallel                                             C
8342 C                                                                              C
8343 C          o             o                                                     C
8344 C         /l\   /   \   /j\                                                    C
8345 C        /   \ /     \ /   \                                                   C
8346 C       /| o |o       o| o |\                                                  C
8347 C       j|/k\|  /      |/k\|l /                                                C
8348 C        /   \ /       /   \ /                                                 C
8349 C       /     o       /     o                                                  C
8350 C       i             i                                                        C
8351 C                                                                              C
8352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8353 C
8354 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8355 C           energy moment and not to the cluster cumulant.
8356       iti=itortyp(itype(i))
8357       if (j.lt.nres-1) then
8358         itj1=itype2loc(itype(j+1))
8359       else
8360         itj1=nloctyp
8361       endif
8362       itk=itype2loc(itype(k))
8363       itk1=itype2loc(itype(k+1))
8364       if (l.lt.nres-1) then
8365         itl1=itype2loc(itype(l+1))
8366       else
8367         itl1=nloctyp
8368       endif
8369 #ifdef MOMENT
8370       s1=dip(4,jj,i)*dip(4,kk,k)
8371 #endif
8372       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8373       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8374       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8375       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8376       call transpose2(EE(1,1,k),auxmat(1,1))
8377       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8378       vv(1)=pizda(1,1)+pizda(2,2)
8379       vv(2)=pizda(2,1)-pizda(1,2)
8380       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8381 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8382 cd     & "sum",-(s2+s3+s4)
8383 #ifdef MOMENT
8384       eello6_graph3=-(s1+s2+s3+s4)
8385 #else
8386       eello6_graph3=-(s2+s3+s4)
8387 #endif
8388 c      eello6_graph3=-s4
8389 C Derivatives in gamma(k-1)
8390       if (calc_grad) then
8391       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8392       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8393       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8394       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8395 C Derivatives in gamma(l-1)
8396       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8397       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8398       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8399       vv(1)=pizda(1,1)+pizda(2,2)
8400       vv(2)=pizda(2,1)-pizda(1,2)
8401       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8402       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8403 C Cartesian derivatives.
8404       do iii=1,2
8405         do kkk=1,5
8406           do lll=1,3
8407 #ifdef MOMENT
8408             if (iii.eq.1) then
8409               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8410             else
8411               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8412             endif
8413 #endif
8414             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8415      &        auxvec(1))
8416             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8417             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8418      &        auxvec(1))
8419             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8420             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8421      &        pizda(1,1))
8422             vv(1)=pizda(1,1)+pizda(2,2)
8423             vv(2)=pizda(2,1)-pizda(1,2)
8424             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8425 #ifdef MOMENT
8426             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8427 #else
8428             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8429 #endif
8430             if (swap) then
8431               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8432             else
8433               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8434             endif
8435 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8436           enddo
8437         enddo
8438       enddo
8439       endif ! calc_grad
8440       return
8441       end
8442 c----------------------------------------------------------------------------
8443       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8444       implicit real*8 (a-h,o-z)
8445       include 'DIMENSIONS'
8446       include 'COMMON.IOUNITS'
8447       include 'COMMON.CHAIN'
8448       include 'COMMON.DERIV'
8449       include 'COMMON.INTERACT'
8450       include 'COMMON.CONTACTS'
8451       include 'COMMON.CONTMAT'
8452       include 'COMMON.CORRMAT'
8453       include 'COMMON.TORSION'
8454       include 'COMMON.VAR'
8455       include 'COMMON.GEO'
8456       include 'COMMON.FFIELD'
8457       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8458      & auxvec1(2),auxmat1(2,2)
8459       logical swap
8460 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8461 C                                                                              C
8462 C      Parallel       Antiparallel                                             C
8463 C                                                                              C
8464 C          o             o                                                     C
8465 C         /l\   /   \   /j\                                                    C
8466 C        /   \ /     \ /   \                                                   C
8467 C       /| o |o       o| o |\                                                  C
8468 C     \ j|/k\|      \  |/k\|l                                                  C
8469 C      \ /   \       \ /   \                                                   C
8470 C       o     \       o     \                                                  C
8471 C       i             i                                                        C
8472 C                                                                              C
8473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8474 C
8475 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8476 C           energy moment and not to the cluster cumulant.
8477 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8478       iti=itype2loc(itype(i))
8479       itj=itype2loc(itype(j))
8480       if (j.lt.nres-1) then
8481         itj1=itype2loc(itype(j+1))
8482       else
8483         itj1=nloctyp
8484       endif
8485       itk=itype2loc(itype(k))
8486       if (k.lt.nres-1) then
8487         itk1=itype2loc(itype(k+1))
8488       else
8489         itk1=nloctyp
8490       endif
8491       itl=itype2loc(itype(l))
8492       if (l.lt.nres-1) then
8493         itl1=itype2loc(itype(l+1))
8494       else
8495         itl1=nloctyp
8496       endif
8497 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8498 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8499 cd     & ' itl',itl,' itl1',itl1
8500 #ifdef MOMENT
8501       if (imat.eq.1) then
8502         s1=dip(3,jj,i)*dip(3,kk,k)
8503       else
8504         s1=dip(2,jj,j)*dip(2,kk,l)
8505       endif
8506 #endif
8507       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8508       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8509       if (j.eq.l+1) then
8510         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8511         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8512       else
8513         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8514         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8515       endif
8516       call transpose2(EUg(1,1,k),auxmat(1,1))
8517       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8518       vv(1)=pizda(1,1)-pizda(2,2)
8519       vv(2)=pizda(2,1)+pizda(1,2)
8520       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8521 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8522 #ifdef MOMENT
8523       eello6_graph4=-(s1+s2+s3+s4)
8524 #else
8525       eello6_graph4=-(s2+s3+s4)
8526 #endif
8527 C Derivatives in gamma(i-1)
8528       if (calc_grad) then
8529       if (i.gt.1) then
8530 #ifdef MOMENT
8531         if (imat.eq.1) then
8532           s1=dipderg(2,jj,i)*dip(3,kk,k)
8533         else
8534           s1=dipderg(4,jj,j)*dip(2,kk,l)
8535         endif
8536 #endif
8537         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8538         if (j.eq.l+1) then
8539           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8540           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8541         else
8542           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8543           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8544         endif
8545         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8546         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8547 cd          write (2,*) 'turn6 derivatives'
8548 #ifdef MOMENT
8549           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8550 #else
8551           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8552 #endif
8553         else
8554 #ifdef MOMENT
8555           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8556 #else
8557           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8558 #endif
8559         endif
8560       endif
8561 C Derivatives in gamma(k-1)
8562 #ifdef MOMENT
8563       if (imat.eq.1) then
8564         s1=dip(3,jj,i)*dipderg(2,kk,k)
8565       else
8566         s1=dip(2,jj,j)*dipderg(4,kk,l)
8567       endif
8568 #endif
8569       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8570       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8571       if (j.eq.l+1) then
8572         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8573         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8574       else
8575         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8576         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8577       endif
8578       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8579       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8580       vv(1)=pizda(1,1)-pizda(2,2)
8581       vv(2)=pizda(2,1)+pizda(1,2)
8582       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8583       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8584 #ifdef MOMENT
8585         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8586 #else
8587         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8588 #endif
8589       else
8590 #ifdef MOMENT
8591         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8592 #else
8593         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8594 #endif
8595       endif
8596 C Derivatives in gamma(j-1) or gamma(l-1)
8597       if (l.eq.j+1 .and. l.gt.1) then
8598         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8599         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8600         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8601         vv(1)=pizda(1,1)-pizda(2,2)
8602         vv(2)=pizda(2,1)+pizda(1,2)
8603         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8604         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8605       else if (j.gt.1) then
8606         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8607         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8608         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8609         vv(1)=pizda(1,1)-pizda(2,2)
8610         vv(2)=pizda(2,1)+pizda(1,2)
8611         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8612         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8613           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8614         else
8615           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8616         endif
8617       endif
8618 C Cartesian derivatives.
8619       do iii=1,2
8620         do kkk=1,5
8621           do lll=1,3
8622 #ifdef MOMENT
8623             if (iii.eq.1) then
8624               if (imat.eq.1) then
8625                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8626               else
8627                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8628               endif
8629             else
8630               if (imat.eq.1) then
8631                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8632               else
8633                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8634               endif
8635             endif
8636 #endif
8637             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8638      &        auxvec(1))
8639             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8640             if (j.eq.l+1) then
8641               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8642      &          b1(1,j+1),auxvec(1))
8643               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8644             else
8645               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8646      &          b1(1,l+1),auxvec(1))
8647               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8648             endif
8649             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8650      &        pizda(1,1))
8651             vv(1)=pizda(1,1)-pizda(2,2)
8652             vv(2)=pizda(2,1)+pizda(1,2)
8653             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8654             if (swap) then
8655               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8656 #ifdef MOMENT
8657                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8658      &             -(s1+s2+s4)
8659 #else
8660                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8661      &             -(s2+s4)
8662 #endif
8663                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8664               else
8665 #ifdef MOMENT
8666                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8667 #else
8668                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8669 #endif
8670                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8671               endif
8672             else
8673 #ifdef MOMENT
8674               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8675 #else
8676               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8677 #endif
8678               if (l.eq.j+1) then
8679                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8680               else
8681                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8682               endif
8683             endif
8684           enddo
8685         enddo
8686       enddo
8687       endif ! calc_grad
8688       return
8689       end
8690 c----------------------------------------------------------------------------
8691       double precision function eello_turn6(i,jj,kk)
8692       implicit real*8 (a-h,o-z)
8693       include 'DIMENSIONS'
8694       include 'COMMON.IOUNITS'
8695       include 'COMMON.CHAIN'
8696       include 'COMMON.DERIV'
8697       include 'COMMON.INTERACT'
8698       include 'COMMON.CONTACTS'
8699       include 'COMMON.CONTMAT'
8700       include 'COMMON.CORRMAT'
8701       include 'COMMON.TORSION'
8702       include 'COMMON.VAR'
8703       include 'COMMON.GEO'
8704       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8705      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8706      &  ggg1(3),ggg2(3)
8707       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8708      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8709 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8710 C           the respective energy moment and not to the cluster cumulant.
8711       s1=0.0d0
8712       s8=0.0d0
8713       s13=0.0d0
8714 c
8715       eello_turn6=0.0d0
8716       j=i+4
8717       k=i+1
8718       l=i+3
8719       iti=itype2loc(itype(i))
8720       itk=itype2loc(itype(k))
8721       itk1=itype2loc(itype(k+1))
8722       itl=itype2loc(itype(l))
8723       itj=itype2loc(itype(j))
8724 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8725 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8726 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8727 cd        eello6=0.0d0
8728 cd        return
8729 cd      endif
8730 cd      write (iout,*)
8731 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8732 cd     &   ' and',k,l
8733 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8734       do iii=1,2
8735         do kkk=1,5
8736           do lll=1,3
8737             derx_turn(lll,kkk,iii)=0.0d0
8738           enddo
8739         enddo
8740       enddo
8741 cd      eij=1.0d0
8742 cd      ekl=1.0d0
8743 cd      ekont=1.0d0
8744       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8745 cd      eello6_5=0.0d0
8746 cd      write (2,*) 'eello6_5',eello6_5
8747 #ifdef MOMENT
8748       call transpose2(AEA(1,1,1),auxmat(1,1))
8749       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8750       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8751       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8752 #endif
8753       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8754       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8755       s2 = scalar2(b1(1,k),vtemp1(1))
8756 #ifdef MOMENT
8757       call transpose2(AEA(1,1,2),atemp(1,1))
8758       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8759       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8760       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8761 #endif
8762       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8763       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8764       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8765 #ifdef MOMENT
8766       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8767       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8768       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8769       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8770       ss13 = scalar2(b1(1,k),vtemp4(1))
8771       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8772 #endif
8773 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8774 c      s1=0.0d0
8775 c      s2=0.0d0
8776 c      s8=0.0d0
8777 c      s12=0.0d0
8778 c      s13=0.0d0
8779       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8780 C Derivatives in gamma(i+2)
8781       if (calc_grad) then
8782       s1d =0.0d0
8783       s8d =0.0d0
8784 #ifdef MOMENT
8785       call transpose2(AEA(1,1,1),auxmatd(1,1))
8786       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8787       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8788       call transpose2(AEAderg(1,1,2),atempd(1,1))
8789       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8790       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8791 #endif
8792       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8793       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8794       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8795 c      s1d=0.0d0
8796 c      s2d=0.0d0
8797 c      s8d=0.0d0
8798 c      s12d=0.0d0
8799 c      s13d=0.0d0
8800       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8801 C Derivatives in gamma(i+3)
8802 #ifdef MOMENT
8803       call transpose2(AEA(1,1,1),auxmatd(1,1))
8804       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8805       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8806       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8807 #endif
8808       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8809       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8810       s2d = scalar2(b1(1,k),vtemp1d(1))
8811 #ifdef MOMENT
8812       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8813       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8814 #endif
8815       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8816 #ifdef MOMENT
8817       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8818       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8819       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8820 #endif
8821 c      s1d=0.0d0
8822 c      s2d=0.0d0
8823 c      s8d=0.0d0
8824 c      s12d=0.0d0
8825 c      s13d=0.0d0
8826 #ifdef MOMENT
8827       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8828      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8829 #else
8830       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8831      &               -0.5d0*ekont*(s2d+s12d)
8832 #endif
8833 C Derivatives in gamma(i+4)
8834       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8835       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8836       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8837 #ifdef MOMENT
8838       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8839       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8840       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8841 #endif
8842 c      s1d=0.0d0
8843 c      s2d=0.0d0
8844 c      s8d=0.0d0
8845 C      s12d=0.0d0
8846 c      s13d=0.0d0
8847 #ifdef MOMENT
8848       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8849 #else
8850       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8851 #endif
8852 C Derivatives in gamma(i+5)
8853 #ifdef MOMENT
8854       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8855       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8856       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8857 #endif
8858       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8859       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8860       s2d = scalar2(b1(1,k),vtemp1d(1))
8861 #ifdef MOMENT
8862       call transpose2(AEA(1,1,2),atempd(1,1))
8863       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8864       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8865 #endif
8866       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8868 #ifdef MOMENT
8869       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8870       ss13d = scalar2(b1(1,k),vtemp4d(1))
8871       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8872 #endif
8873 c      s1d=0.0d0
8874 c      s2d=0.0d0
8875 c      s8d=0.0d0
8876 c      s12d=0.0d0
8877 c      s13d=0.0d0
8878 #ifdef MOMENT
8879       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8880      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8881 #else
8882       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8883      &               -0.5d0*ekont*(s2d+s12d)
8884 #endif
8885 C Cartesian derivatives
8886       do iii=1,2
8887         do kkk=1,5
8888           do lll=1,3
8889 #ifdef MOMENT
8890             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8891             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8892             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8893 #endif
8894             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8895             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8896      &          vtemp1d(1))
8897             s2d = scalar2(b1(1,k),vtemp1d(1))
8898 #ifdef MOMENT
8899             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8900             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8901             s8d = -(atempd(1,1)+atempd(2,2))*
8902      &           scalar2(cc(1,1,l),vtemp2(1))
8903 #endif
8904             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8905      &           auxmatd(1,1))
8906             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8907             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8908 c      s1d=0.0d0
8909 c      s2d=0.0d0
8910 c      s8d=0.0d0
8911 c      s12d=0.0d0
8912 c      s13d=0.0d0
8913 #ifdef MOMENT
8914             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8915      &        - 0.5d0*(s1d+s2d)
8916 #else
8917             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8918      &        - 0.5d0*s2d
8919 #endif
8920 #ifdef MOMENT
8921             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8922      &        - 0.5d0*(s8d+s12d)
8923 #else
8924             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8925      &        - 0.5d0*s12d
8926 #endif
8927           enddo
8928         enddo
8929       enddo
8930 #ifdef MOMENT
8931       do kkk=1,5
8932         do lll=1,3
8933           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8934      &      achuj_tempd(1,1))
8935           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8936           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8937           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8938           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8939           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8940      &      vtemp4d(1))
8941           ss13d = scalar2(b1(1,k),vtemp4d(1))
8942           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8943           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8944         enddo
8945       enddo
8946 #endif
8947 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8948 cd     &  16*eel_turn6_num
8949 cd      goto 1112
8950       if (j.lt.nres-1) then
8951         j1=j+1
8952         j2=j-1
8953       else
8954         j1=j-1
8955         j2=j-2
8956       endif
8957       if (l.lt.nres-1) then
8958         l1=l+1
8959         l2=l-1
8960       else
8961         l1=l-1
8962         l2=l-2
8963       endif
8964       do ll=1,3
8965 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8966 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8967 cgrad        ghalf=0.5d0*ggg1(ll)
8968 cd        ghalf=0.0d0
8969         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8970         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8971         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8972      &    +ekont*derx_turn(ll,2,1)
8973         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8974         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8975      &    +ekont*derx_turn(ll,4,1)
8976         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8977         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8978         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8979 cgrad        ghalf=0.5d0*ggg2(ll)
8980 cd        ghalf=0.0d0
8981         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8982      &    +ekont*derx_turn(ll,2,2)
8983         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8984         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8985      &    +ekont*derx_turn(ll,4,2)
8986         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8987         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8988         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8989       enddo
8990 cd      goto 1112
8991 cgrad      do m=i+1,j-1
8992 cgrad        do ll=1,3
8993 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8994 cgrad        enddo
8995 cgrad      enddo
8996 cgrad      do m=k+1,l-1
8997 cgrad        do ll=1,3
8998 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8999 cgrad        enddo
9000 cgrad      enddo
9001 cgrad1112  continue
9002 cgrad      do m=i+2,j2
9003 cgrad        do ll=1,3
9004 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9005 cgrad        enddo
9006 cgrad      enddo
9007 cgrad      do m=k+2,l2
9008 cgrad        do ll=1,3
9009 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9010 cgrad        enddo
9011 cgrad      enddo
9012 cd      do iii=1,nres-3
9013 cd        write (2,*) iii,g_corr6_loc(iii)
9014 cd      enddo
9015       endif ! calc_grad
9016       eello_turn6=ekont*eel_turn6
9017 cd      write (2,*) 'ekont',ekont
9018 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9019       return
9020       end
9021 #endif
9022 crc-------------------------------------------------
9023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9024       subroutine Eliptransfer(eliptran)
9025       implicit real*8 (a-h,o-z)
9026       include 'DIMENSIONS'
9027       include 'COMMON.GEO'
9028       include 'COMMON.VAR'
9029       include 'COMMON.LOCAL'
9030       include 'COMMON.CHAIN'
9031       include 'COMMON.DERIV'
9032       include 'COMMON.INTERACT'
9033       include 'COMMON.IOUNITS'
9034       include 'COMMON.CALC'
9035       include 'COMMON.CONTROL'
9036       include 'COMMON.SPLITELE'
9037       include 'COMMON.SBRIDGE'
9038 C this is done by Adasko
9039 C      print *,"wchodze"
9040 C structure of box:
9041 C      water
9042 C--bordliptop-- buffore starts
9043 C--bufliptop--- here true lipid starts
9044 C      lipid
9045 C--buflipbot--- lipid ends buffore starts
9046 C--bordlipbot--buffore ends
9047       eliptran=0.0
9048       do i=1,nres
9049 C       do i=1,1
9050         if (itype(i).eq.ntyp1) cycle
9051
9052         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9053         if (positi.le.0) positi=positi+boxzsize
9054 C        print *,i
9055 C first for peptide groups
9056 c for each residue check if it is in lipid or lipid water border area
9057        if ((positi.gt.bordlipbot)
9058      &.and.(positi.lt.bordliptop)) then
9059 C the energy transfer exist
9060         if (positi.lt.buflipbot) then
9061 C what fraction I am in
9062          fracinbuf=1.0d0-
9063      &        ((positi-bordlipbot)/lipbufthick)
9064 C lipbufthick is thickenes of lipid buffore
9065          sslip=sscalelip(fracinbuf)
9066          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9067          eliptran=eliptran+sslip*pepliptran
9068          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9069          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9070 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9071         elseif (positi.gt.bufliptop) then
9072          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9073          sslip=sscalelip(fracinbuf)
9074          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9075          eliptran=eliptran+sslip*pepliptran
9076          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9077          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9078 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9079 C          print *, "doing sscalefor top part"
9080 C         print *,i,sslip,fracinbuf,ssgradlip
9081         else
9082          eliptran=eliptran+pepliptran
9083 C         print *,"I am in true lipid"
9084         endif
9085 C       else
9086 C       eliptran=elpitran+0.0 ! I am in water
9087        endif
9088        enddo
9089 C       print *, "nic nie bylo w lipidzie?"
9090 C now multiply all by the peptide group transfer factor
9091 C       eliptran=eliptran*pepliptran
9092 C now the same for side chains
9093 CV       do i=1,1
9094        do i=1,nres
9095         if (itype(i).eq.ntyp1) cycle
9096         positi=(mod(c(3,i+nres),boxzsize))
9097         if (positi.le.0) positi=positi+boxzsize
9098 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9099 c for each residue check if it is in lipid or lipid water border area
9100 C       respos=mod(c(3,i+nres),boxzsize)
9101 C       print *,positi,bordlipbot,buflipbot
9102        if ((positi.gt.bordlipbot)
9103      & .and.(positi.lt.bordliptop)) then
9104 C the energy transfer exist
9105         if (positi.lt.buflipbot) then
9106          fracinbuf=1.0d0-
9107      &     ((positi-bordlipbot)/lipbufthick)
9108 C lipbufthick is thickenes of lipid buffore
9109          sslip=sscalelip(fracinbuf)
9110          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9111          eliptran=eliptran+sslip*liptranene(itype(i))
9112          gliptranx(3,i)=gliptranx(3,i)
9113      &+ssgradlip*liptranene(itype(i))
9114          gliptranc(3,i-1)= gliptranc(3,i-1)
9115      &+ssgradlip*liptranene(itype(i))
9116 C         print *,"doing sccale for lower part"
9117         elseif (positi.gt.bufliptop) then
9118          fracinbuf=1.0d0-
9119      &((bordliptop-positi)/lipbufthick)
9120          sslip=sscalelip(fracinbuf)
9121          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9122          eliptran=eliptran+sslip*liptranene(itype(i))
9123          gliptranx(3,i)=gliptranx(3,i)
9124      &+ssgradlip*liptranene(itype(i))
9125          gliptranc(3,i-1)= gliptranc(3,i-1)
9126      &+ssgradlip*liptranene(itype(i))
9127 C          print *, "doing sscalefor top part",sslip,fracinbuf
9128         else
9129          eliptran=eliptran+liptranene(itype(i))
9130 C         print *,"I am in true lipid"
9131         endif
9132         endif ! if in lipid or buffor
9133 C       else
9134 C       eliptran=elpitran+0.0 ! I am in water
9135        enddo
9136        return
9137        end
9138
9139
9140 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9141
9142       SUBROUTINE MATVEC2(A1,V1,V2)
9143       implicit real*8 (a-h,o-z)
9144       include 'DIMENSIONS'
9145       DIMENSION A1(2,2),V1(2),V2(2)
9146 c      DO 1 I=1,2
9147 c        VI=0.0
9148 c        DO 3 K=1,2
9149 c    3     VI=VI+A1(I,K)*V1(K)
9150 c        Vaux(I)=VI
9151 c    1 CONTINUE
9152
9153       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9154       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9155
9156       v2(1)=vaux1
9157       v2(2)=vaux2
9158       END
9159 C---------------------------------------
9160       SUBROUTINE MATMAT2(A1,A2,A3)
9161       implicit real*8 (a-h,o-z)
9162       include 'DIMENSIONS'
9163       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9164 c      DIMENSION AI3(2,2)
9165 c        DO  J=1,2
9166 c          A3IJ=0.0
9167 c          DO K=1,2
9168 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9169 c          enddo
9170 c          A3(I,J)=A3IJ
9171 c       enddo
9172 c      enddo
9173
9174       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9175       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9176       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9177       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9178
9179       A3(1,1)=AI3_11
9180       A3(2,1)=AI3_21
9181       A3(1,2)=AI3_12
9182       A3(2,2)=AI3_22
9183       END
9184
9185 c-------------------------------------------------------------------------
9186       double precision function scalar2(u,v)
9187       implicit none
9188       double precision u(2),v(2)
9189       double precision sc
9190       integer i
9191       scalar2=u(1)*v(1)+u(2)*v(2)
9192       return
9193       end
9194
9195 C-----------------------------------------------------------------------------
9196
9197       subroutine transpose2(a,at)
9198       implicit none
9199       double precision a(2,2),at(2,2)
9200       at(1,1)=a(1,1)
9201       at(1,2)=a(2,1)
9202       at(2,1)=a(1,2)
9203       at(2,2)=a(2,2)
9204       return
9205       end
9206 c--------------------------------------------------------------------------
9207       subroutine transpose(n,a,at)
9208       implicit none
9209       integer n,i,j
9210       double precision a(n,n),at(n,n)
9211       do i=1,n
9212         do j=1,n
9213           at(j,i)=a(i,j)
9214         enddo
9215       enddo
9216       return
9217       end
9218 C---------------------------------------------------------------------------
9219       subroutine prodmat3(a1,a2,kk,transp,prod)
9220       implicit none
9221       integer i,j
9222       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9223       logical transp
9224 crc      double precision auxmat(2,2),prod_(2,2)
9225
9226       if (transp) then
9227 crc        call transpose2(kk(1,1),auxmat(1,1))
9228 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9229 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9230
9231            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9232      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9233            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9234      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9235            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9236      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9237            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9238      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9239
9240       else
9241 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9242 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9243
9244            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9245      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9246            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9247      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9248            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9249      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9250            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9251      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9252
9253       endif
9254 c      call transpose2(a2(1,1),a2t(1,1))
9255
9256 crc      print *,transp
9257 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9258 crc      print *,((prod(i,j),i=1,2),j=1,2)
9259
9260       return
9261       end
9262 C-----------------------------------------------------------------------------
9263       double precision function scalar(u,v)
9264       implicit none
9265       double precision u(3),v(3)
9266       double precision sc
9267       integer i
9268       sc=0.0d0
9269       do i=1,3
9270         sc=sc+u(i)*v(i)
9271       enddo
9272       scalar=sc
9273       return
9274       end
9275 C-----------------------------------------------------------------------
9276       double precision function sscale(r)
9277       double precision r,gamm
9278       include "COMMON.SPLITELE"
9279       if(r.lt.r_cut-rlamb) then
9280         sscale=1.0d0
9281       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9282         gamm=(r-(r_cut-rlamb))/rlamb
9283         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9284       else
9285         sscale=0d0
9286       endif
9287       return
9288       end
9289 C-----------------------------------------------------------------------
9290 C-----------------------------------------------------------------------
9291       double precision function sscagrad(r)
9292       double precision r,gamm
9293       include "COMMON.SPLITELE"
9294       if(r.lt.r_cut-rlamb) then
9295         sscagrad=0.0d0
9296       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9297         gamm=(r-(r_cut-rlamb))/rlamb
9298         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9299       else
9300         sscagrad=0.0d0
9301       endif
9302       return
9303       end
9304 C-----------------------------------------------------------------------
9305 C-----------------------------------------------------------------------
9306       double precision function sscalelip(r)
9307       double precision r,gamm
9308       include "COMMON.SPLITELE"
9309 C      if(r.lt.r_cut-rlamb) then
9310 C        sscale=1.0d0
9311 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9312 C        gamm=(r-(r_cut-rlamb))/rlamb
9313         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9314 C      else
9315 C        sscale=0d0
9316 C      endif
9317       return
9318       end
9319 C-----------------------------------------------------------------------
9320       double precision function sscagradlip(r)
9321       double precision r,gamm
9322       include "COMMON.SPLITELE"
9323 C     if(r.lt.r_cut-rlamb) then
9324 C        sscagrad=0.0d0
9325 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9326 C        gamm=(r-(r_cut-rlamb))/rlamb
9327         sscagradlip=r*(6*r-6.0d0)
9328 C      else
9329 C        sscagrad=0.0d0
9330 C      endif
9331       return
9332       end
9333
9334 C-----------------------------------------------------------------------
9335        subroutine set_shield_fac
9336       implicit real*8 (a-h,o-z)
9337       include 'DIMENSIONS'
9338       include 'COMMON.CHAIN'
9339       include 'COMMON.DERIV'
9340       include 'COMMON.IOUNITS'
9341       include 'COMMON.SHIELD'
9342       include 'COMMON.INTERACT'
9343 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9344       double precision div77_81/0.974996043d0/,
9345      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9346
9347 C the vector between center of side_chain and peptide group
9348        double precision pep_side(3),long,side_calf(3),
9349      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9350      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9351 C the line belowe needs to be changed for FGPROC>1
9352       do i=1,nres-1
9353       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9354       ishield_list(i)=0
9355 Cif there two consequtive dummy atoms there is no peptide group between them
9356 C the line below has to be changed for FGPROC>1
9357       VolumeTotal=0.0
9358       do k=1,nres
9359        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9360        dist_pep_side=0.0
9361        dist_side_calf=0.0
9362        do j=1,3
9363 C first lets set vector conecting the ithe side-chain with kth side-chain
9364       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9365 C      pep_side(j)=2.0d0
9366 C and vector conecting the side-chain with its proper calfa
9367       side_calf(j)=c(j,k+nres)-c(j,k)
9368 C      side_calf(j)=2.0d0
9369       pept_group(j)=c(j,i)-c(j,i+1)
9370 C lets have their lenght
9371       dist_pep_side=pep_side(j)**2+dist_pep_side
9372       dist_side_calf=dist_side_calf+side_calf(j)**2
9373       dist_pept_group=dist_pept_group+pept_group(j)**2
9374       enddo
9375        dist_pep_side=dsqrt(dist_pep_side)
9376        dist_pept_group=dsqrt(dist_pept_group)
9377        dist_side_calf=dsqrt(dist_side_calf)
9378       do j=1,3
9379         pep_side_norm(j)=pep_side(j)/dist_pep_side
9380         side_calf_norm(j)=dist_side_calf
9381       enddo
9382 C now sscale fraction
9383        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9384 C       print *,buff_shield,"buff"
9385 C now sscale
9386         if (sh_frac_dist.le.0.0) cycle
9387 C If we reach here it means that this side chain reaches the shielding sphere
9388 C Lets add him to the list for gradient
9389         ishield_list(i)=ishield_list(i)+1
9390 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9391 C this list is essential otherwise problem would be O3
9392         shield_list(ishield_list(i),i)=k
9393 C Lets have the sscale value
9394         if (sh_frac_dist.gt.1.0) then
9395          scale_fac_dist=1.0d0
9396          do j=1,3
9397          sh_frac_dist_grad(j)=0.0d0
9398          enddo
9399         else
9400          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9401      &                   *(2.0*sh_frac_dist-3.0d0)
9402          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9403      &                  /dist_pep_side/buff_shield*0.5
9404 C remember for the final gradient multiply sh_frac_dist_grad(j)
9405 C for side_chain by factor -2 !
9406          do j=1,3
9407          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9408 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9409 C     &                    sh_frac_dist_grad(j)
9410          enddo
9411         endif
9412 C        if ((i.eq.3).and.(k.eq.2)) then
9413 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9414 C     & ,"TU"
9415 C        endif
9416
9417 C this is what is now we have the distance scaling now volume...
9418       short=short_r_sidechain(itype(k))
9419       long=long_r_sidechain(itype(k))
9420       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9421 C now costhet_grad
9422 C       costhet=0.0d0
9423        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9424 C       costhet_fac=0.0d0
9425        do j=1,3
9426          costhet_grad(j)=costhet_fac*pep_side(j)
9427        enddo
9428 C remember for the final gradient multiply costhet_grad(j)
9429 C for side_chain by factor -2 !
9430 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9431 C pep_side0pept_group is vector multiplication
9432       pep_side0pept_group=0.0
9433       do j=1,3
9434       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9435       enddo
9436       cosalfa=(pep_side0pept_group/
9437      & (dist_pep_side*dist_side_calf))
9438       fac_alfa_sin=1.0-cosalfa**2
9439       fac_alfa_sin=dsqrt(fac_alfa_sin)
9440       rkprim=fac_alfa_sin*(long-short)+short
9441 C now costhet_grad
9442        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9443        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9444
9445        do j=1,3
9446          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9447      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9448      &*(long-short)/fac_alfa_sin*cosalfa/
9449      &((dist_pep_side*dist_side_calf))*
9450      &((side_calf(j))-cosalfa*
9451      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9452
9453         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9454      &*(long-short)/fac_alfa_sin*cosalfa
9455      &/((dist_pep_side*dist_side_calf))*
9456      &(pep_side(j)-
9457      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9458        enddo
9459
9460       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9461      &                    /VSolvSphere_div
9462      &                    *wshield
9463 C now the gradient...
9464 C grad_shield is gradient of Calfa for peptide groups
9465 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9466 C     &               costhet,cosphi
9467 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9468 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9469       do j=1,3
9470       grad_shield(j,i)=grad_shield(j,i)
9471 C gradient po skalowaniu
9472      &                +(sh_frac_dist_grad(j)
9473 C  gradient po costhet
9474      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9475      &-scale_fac_dist*(cosphi_grad_long(j))
9476      &/(1.0-cosphi) )*div77_81
9477      &*VofOverlap
9478 C grad_shield_side is Cbeta sidechain gradient
9479       grad_shield_side(j,ishield_list(i),i)=
9480      &        (sh_frac_dist_grad(j)*(-2.0d0)
9481      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9482      &       +scale_fac_dist*(cosphi_grad_long(j))
9483      &        *2.0d0/(1.0-cosphi))
9484      &        *div77_81*VofOverlap
9485
9486        grad_shield_loc(j,ishield_list(i),i)=
9487      &   scale_fac_dist*cosphi_grad_loc(j)
9488      &        *2.0d0/(1.0-cosphi)
9489      &        *div77_81*VofOverlap
9490       enddo
9491       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9492       enddo
9493       fac_shield(i)=VolumeTotal*div77_81+div4_81
9494 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9495       enddo
9496       return
9497       end
9498 C--------------------------------------------------------------------------
9499 C first for shielding is setting of function of side-chains
9500        subroutine set_shield_fac2
9501       implicit real*8 (a-h,o-z)
9502       include 'DIMENSIONS'
9503       include 'COMMON.CHAIN'
9504       include 'COMMON.DERIV'
9505       include 'COMMON.IOUNITS'
9506       include 'COMMON.SHIELD'
9507       include 'COMMON.INTERACT'
9508 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9509       double precision div77_81/0.974996043d0/,
9510      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9511
9512 C the vector between center of side_chain and peptide group
9513        double precision pep_side(3),long,side_calf(3),
9514      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9515      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9516 C the line belowe needs to be changed for FGPROC>1
9517       do i=1,nres-1
9518       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9519       ishield_list(i)=0
9520 Cif there two consequtive dummy atoms there is no peptide group between them
9521 C the line below has to be changed for FGPROC>1
9522       VolumeTotal=0.0
9523       do k=1,nres
9524        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9525        dist_pep_side=0.0
9526        dist_side_calf=0.0
9527        do j=1,3
9528 C first lets set vector conecting the ithe side-chain with kth side-chain
9529       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9530 C      pep_side(j)=2.0d0
9531 C and vector conecting the side-chain with its proper calfa
9532       side_calf(j)=c(j,k+nres)-c(j,k)
9533 C      side_calf(j)=2.0d0
9534       pept_group(j)=c(j,i)-c(j,i+1)
9535 C lets have their lenght
9536       dist_pep_side=pep_side(j)**2+dist_pep_side
9537       dist_side_calf=dist_side_calf+side_calf(j)**2
9538       dist_pept_group=dist_pept_group+pept_group(j)**2
9539       enddo
9540        dist_pep_side=dsqrt(dist_pep_side)
9541        dist_pept_group=dsqrt(dist_pept_group)
9542        dist_side_calf=dsqrt(dist_side_calf)
9543       do j=1,3
9544         pep_side_norm(j)=pep_side(j)/dist_pep_side
9545         side_calf_norm(j)=dist_side_calf
9546       enddo
9547 C now sscale fraction
9548        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9549 C       print *,buff_shield,"buff"
9550 C now sscale
9551         if (sh_frac_dist.le.0.0) cycle
9552 C If we reach here it means that this side chain reaches the shielding sphere
9553 C Lets add him to the list for gradient
9554         ishield_list(i)=ishield_list(i)+1
9555 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9556 C this list is essential otherwise problem would be O3
9557         shield_list(ishield_list(i),i)=k
9558 C Lets have the sscale value
9559         if (sh_frac_dist.gt.1.0) then
9560          scale_fac_dist=1.0d0
9561          do j=1,3
9562          sh_frac_dist_grad(j)=0.0d0
9563          enddo
9564         else
9565          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9566      &                   *(2.0d0*sh_frac_dist-3.0d0)
9567          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9568      &                  /dist_pep_side/buff_shield*0.5d0
9569 C remember for the final gradient multiply sh_frac_dist_grad(j)
9570 C for side_chain by factor -2 !
9571          do j=1,3
9572          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9573 C         sh_frac_dist_grad(j)=0.0d0
9574 C         scale_fac_dist=1.0d0
9575 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9576 C     &                    sh_frac_dist_grad(j)
9577          enddo
9578         endif
9579 C this is what is now we have the distance scaling now volume...
9580       short=short_r_sidechain(itype(k))
9581       long=long_r_sidechain(itype(k))
9582       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9583       sinthet=short/dist_pep_side*costhet
9584 C now costhet_grad
9585 C       costhet=0.6d0
9586 C       sinthet=0.8
9587        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9588 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9589 C     &             -short/dist_pep_side**2/costhet)
9590 C       costhet_fac=0.0d0
9591        do j=1,3
9592          costhet_grad(j)=costhet_fac*pep_side(j)
9593        enddo
9594 C remember for the final gradient multiply costhet_grad(j)
9595 C for side_chain by factor -2 !
9596 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9597 C pep_side0pept_group is vector multiplication
9598       pep_side0pept_group=0.0d0
9599       do j=1,3
9600       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9601       enddo
9602       cosalfa=(pep_side0pept_group/
9603      & (dist_pep_side*dist_side_calf))
9604       fac_alfa_sin=1.0d0-cosalfa**2
9605       fac_alfa_sin=dsqrt(fac_alfa_sin)
9606       rkprim=fac_alfa_sin*(long-short)+short
9607 C      rkprim=short
9608
9609 C now costhet_grad
9610        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9611 C       cosphi=0.6
9612        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9613        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9614      &      dist_pep_side**2)
9615 C       sinphi=0.8
9616        do j=1,3
9617          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9618      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9619      &*(long-short)/fac_alfa_sin*cosalfa/
9620      &((dist_pep_side*dist_side_calf))*
9621      &((side_calf(j))-cosalfa*
9622      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9623 C       cosphi_grad_long(j)=0.0d0
9624         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9625      &*(long-short)/fac_alfa_sin*cosalfa
9626      &/((dist_pep_side*dist_side_calf))*
9627      &(pep_side(j)-
9628      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9629 C       cosphi_grad_loc(j)=0.0d0
9630        enddo
9631 C      print *,sinphi,sinthet
9632       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9633      &                    /VSolvSphere_div
9634 C     &                    *wshield
9635 C now the gradient...
9636       do j=1,3
9637       grad_shield(j,i)=grad_shield(j,i)
9638 C gradient po skalowaniu
9639      &                +(sh_frac_dist_grad(j)*VofOverlap
9640 C  gradient po costhet
9641      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9642      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9643      &       sinphi/sinthet*costhet*costhet_grad(j)
9644      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9645      & )*wshield
9646 C grad_shield_side is Cbeta sidechain gradient
9647       grad_shield_side(j,ishield_list(i),i)=
9648      &        (sh_frac_dist_grad(j)*(-2.0d0)
9649      &        *VofOverlap
9650      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9651      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9652      &       sinphi/sinthet*costhet*costhet_grad(j)
9653      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9654      &       )*wshield
9655
9656        grad_shield_loc(j,ishield_list(i),i)=
9657      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9658      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9659      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9660      &        ))
9661      &        *wshield
9662       enddo
9663       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9664       enddo
9665       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9666 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9667 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9668       enddo
9669       return
9670       end
9671 C--------------------------------------------------------------------------
9672       double precision function tschebyshev(m,n,x,y)
9673       implicit none
9674       include "DIMENSIONS"
9675       integer i,m,n
9676       double precision x(n),y,yy(0:maxvar),aux
9677 c Tschebyshev polynomial. Note that the first term is omitted
9678 c m=0: the constant term is included
9679 c m=1: the constant term is not included
9680       yy(0)=1.0d0
9681       yy(1)=y
9682       do i=2,n
9683         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9684       enddo
9685       aux=0.0d0
9686       do i=m,n
9687         aux=aux+x(i)*yy(i)
9688       enddo
9689       tschebyshev=aux
9690       return
9691       end
9692 C--------------------------------------------------------------------------
9693       double precision function gradtschebyshev(m,n,x,y)
9694       implicit none
9695       include "DIMENSIONS"
9696       integer i,m,n
9697       double precision x(n+1),y,yy(0:maxvar),aux
9698 c Tschebyshev polynomial. Note that the first term is omitted
9699 c m=0: the constant term is included
9700 c m=1: the constant term is not included
9701       yy(0)=1.0d0
9702       yy(1)=2.0d0*y
9703       do i=2,n
9704         yy(i)=2*y*yy(i-1)-yy(i-2)
9705       enddo
9706       aux=0.0d0
9707       do i=m,n
9708         aux=aux+x(i+1)*yy(i)*(i+1)
9709 C        print *, x(i+1),yy(i),i
9710       enddo
9711       gradtschebyshev=aux
9712       return
9713       end
9714 c----------------------------------------------------------------------------
9715       double precision function sscale2(r,r_cut,r0,rlamb)
9716       implicit none
9717       double precision r,gamm,r_cut,r0,rlamb,rr
9718       rr = dabs(r-r0)
9719 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9720 c      write (2,*) "rr",rr
9721       if(rr.lt.r_cut-rlamb) then
9722         sscale2=1.0d0
9723       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9724         gamm=(rr-(r_cut-rlamb))/rlamb
9725         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9726       else
9727         sscale2=0d0
9728       endif
9729       return
9730       end
9731 C-----------------------------------------------------------------------
9732       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9733       implicit none
9734       double precision r,gamm,r_cut,r0,rlamb,rr
9735       rr = dabs(r-r0)
9736       if(rr.lt.r_cut-rlamb) then
9737         sscalgrad2=0.0d0
9738       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9739         gamm=(rr-(r_cut-rlamb))/rlamb
9740         if (r.ge.r0) then
9741           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9742         else
9743           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9744         endif
9745       else
9746         sscalgrad2=0.0d0
9747       endif
9748       return
9749       end
9750 c----------------------------------------------------------------------------
9751       subroutine e_saxs(Esaxs_constr)
9752       implicit none
9753       include 'DIMENSIONS'
9754 #ifdef MPI
9755       include "mpif.h"
9756       include "COMMON.SETUP"
9757       integer IERR
9758 #endif
9759       include 'COMMON.SBRIDGE'
9760       include 'COMMON.CHAIN'
9761       include 'COMMON.GEO'
9762       include 'COMMON.LOCAL'
9763       include 'COMMON.INTERACT'
9764       include 'COMMON.VAR'
9765       include 'COMMON.IOUNITS'
9766       include 'COMMON.DERIV'
9767       include 'COMMON.CONTROL'
9768       include 'COMMON.NAMES'
9769       include 'COMMON.FFIELD'
9770       include 'COMMON.LANGEVIN'
9771       include 'COMMON.SAXS'
9772 c
9773       double precision Esaxs_constr
9774       integer i,iint,j,k,l
9775       double precision PgradC(maxSAXS,3,maxres),
9776      &  PgradX(maxSAXS,3,maxres)
9777 #ifdef MPI
9778       double precision PgradC_(maxSAXS,3,maxres),
9779      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9780 #endif
9781       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9782      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9783      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9784      & auxX,auxX1,CACAgrad,Cnorm
9785       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9786       double precision dist
9787       external dist
9788 c  SAXS restraint penalty function
9789 #ifdef DEBUG
9790       write(iout,*) "------- SAXS penalty function start -------"
9791       write (iout,*) "nsaxs",nsaxs
9792       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9793       write (iout,*) "Psaxs"
9794       do i=1,nsaxs
9795         write (iout,'(i5,e15.5)') i, Psaxs(i)
9796       enddo
9797 #endif
9798       Esaxs_constr = 0.0d0
9799       do k=1,nsaxs
9800         Pcalc(k)=0.0d0
9801         do j=1,nres
9802           do l=1,3
9803             PgradC(k,l,j)=0.0d0
9804             PgradX(k,l,j)=0.0d0
9805           enddo
9806         enddo
9807       enddo
9808       do i=iatsc_s,iatsc_e
9809        if (itype(i).eq.ntyp1) cycle
9810        do iint=1,nint_gr(i)
9811          do j=istart(i,iint),iend(i,iint)
9812            if (itype(j).eq.ntyp1) cycle
9813 #ifdef ALLSAXS
9814            dijCACA=dist(i,j)
9815            dijCASC=dist(i,j+nres)
9816            dijSCCA=dist(i+nres,j)
9817            dijSCSC=dist(i+nres,j+nres)
9818            sigma2CACA=2.0d0/(pstok**2)
9819            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9820            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9821            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9822            do k=1,nsaxs
9823              dk = distsaxs(k)
9824              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9825              if (itype(j).ne.10) then
9826              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9827              else
9828              endif
9829              expCASC = 0.0d0
9830              if (itype(i).ne.10) then
9831              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9832              else
9833              expSCCA = 0.0d0
9834              endif
9835              if (itype(i).ne.10 .and. itype(j).ne.10) then
9836              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9837              else
9838              expSCSC = 0.0d0
9839              endif
9840              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9841 #ifdef DEBUG
9842              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9843 #endif
9844              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9845              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9846              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9847              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9848              do l=1,3
9849 c CA CA
9850                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9851                PgradC(k,l,i) = PgradC(k,l,i)-aux
9852                PgradC(k,l,j) = PgradC(k,l,j)+aux
9853 c CA SC
9854                if (itype(j).ne.10) then
9855                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9856                PgradC(k,l,i) = PgradC(k,l,i)-aux
9857                PgradC(k,l,j) = PgradC(k,l,j)+aux
9858                PgradX(k,l,j) = PgradX(k,l,j)+aux
9859                endif
9860 c SC CA
9861                if (itype(i).ne.10) then
9862                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9863                PgradX(k,l,i) = PgradX(k,l,i)-aux
9864                PgradC(k,l,i) = PgradC(k,l,i)-aux
9865                PgradC(k,l,j) = PgradC(k,l,j)+aux
9866                endif
9867 c SC SC
9868                if (itype(i).ne.10 .and. itype(j).ne.10) then
9869                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9870                PgradC(k,l,i) = PgradC(k,l,i)-aux
9871                PgradC(k,l,j) = PgradC(k,l,j)+aux
9872                PgradX(k,l,i) = PgradX(k,l,i)-aux
9873                PgradX(k,l,j) = PgradX(k,l,j)+aux
9874                endif
9875              enddo ! l
9876            enddo ! k
9877 #else
9878            dijCACA=dist(i,j)
9879            sigma2CACA=scal_rad**2*0.25d0/
9880      &        (restok(itype(j))**2+restok(itype(i))**2)
9881
9882            IF (saxs_cutoff.eq.0) THEN
9883            do k=1,nsaxs
9884              dk = distsaxs(k)
9885              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9886              Pcalc(k) = Pcalc(k)+expCACA
9887              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9888              do l=1,3
9889                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9890                PgradC(k,l,i) = PgradC(k,l,i)-aux
9891                PgradC(k,l,j) = PgradC(k,l,j)+aux
9892              enddo ! l
9893            enddo ! k
9894            ELSE
9895            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9896            do k=1,nsaxs
9897              dk = distsaxs(k)
9898 c             write (2,*) "ijk",i,j,k
9899              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9900              if (sss2.eq.0.0d0) cycle
9901              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9902              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9903              Pcalc(k) = Pcalc(k)+expCACA
9904 #ifdef DEBUG
9905              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9906 #endif
9907              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9908      &             ssgrad2*expCACA/sss2
9909              do l=1,3
9910 c CA CA
9911                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9912                PgradC(k,l,i) = PgradC(k,l,i)+aux
9913                PgradC(k,l,j) = PgradC(k,l,j)-aux
9914              enddo ! l
9915            enddo ! k
9916            ENDIF
9917 #endif
9918          enddo ! j
9919        enddo ! iint
9920       enddo ! i
9921 #ifdef MPI
9922       if (nfgtasks.gt.1) then
9923         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9924      &    MPI_SUM,king,FG_COMM,IERR)
9925         if (fg_rank.eq.king) then
9926           do k=1,nsaxs
9927             Pcalc(k) = Pcalc_(k)
9928           enddo
9929         endif
9930         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9931      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9932         if (fg_rank.eq.king) then
9933           do i=1,nres
9934             do l=1,3
9935               do k=1,nsaxs
9936                 PgradC(k,l,i) = PgradC_(k,l,i)
9937               enddo
9938             enddo
9939           enddo
9940         endif
9941 #ifdef ALLSAXS
9942         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9943      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9944         if (fg_rank.eq.king) then
9945           do i=1,nres
9946             do l=1,3
9947               do k=1,nsaxs
9948                 PgradX(k,l,i) = PgradX_(k,l,i)
9949               enddo
9950             enddo
9951           enddo
9952         endif
9953 #endif
9954       endif
9955 #endif
9956 #ifdef MPI
9957       if (fg_rank.eq.king) then
9958 #endif
9959       Cnorm = 0.0d0
9960       do k=1,nsaxs
9961         Cnorm = Cnorm + Pcalc(k)
9962       enddo
9963       Esaxs_constr = dlog(Cnorm)-wsaxs0
9964       do k=1,nsaxs
9965         if (Pcalc(k).gt.0.0d0)
9966      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9967 #ifdef DEBUG
9968         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9969 #endif
9970       enddo
9971 #ifdef DEBUG
9972       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9973 #endif
9974       do i=nnt,nct
9975         do l=1,3
9976           auxC=0.0d0
9977           auxC1=0.0d0
9978           auxX=0.0d0
9979           auxX1=0.d0
9980           do k=1,nsaxs
9981             if (Pcalc(k).gt.0)
9982      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9983             auxC1 = auxC1+PgradC(k,l,i)
9984 #ifdef ALLSAXS
9985             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9986             auxX1 = auxX1+PgradX(k,l,i)
9987 #endif
9988           enddo
9989           gsaxsC(l,i) = auxC - auxC1/Cnorm
9990 #ifdef ALLSAXS
9991           gsaxsX(l,i) = auxX - auxX1/Cnorm
9992 #endif
9993 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9994 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9995         enddo
9996       enddo
9997 #ifdef MPI
9998       endif
9999 #endif
10000       return
10001       end
10002 c----------------------------------------------------------------------------
10003       subroutine e_saxsC(Esaxs_constr)
10004       implicit none
10005       include 'DIMENSIONS'
10006 #ifdef MPI
10007       include "mpif.h"
10008       include "COMMON.SETUP"
10009       integer IERR
10010 #endif
10011       include 'COMMON.SBRIDGE'
10012       include 'COMMON.CHAIN'
10013       include 'COMMON.GEO'
10014       include 'COMMON.LOCAL'
10015       include 'COMMON.INTERACT'
10016       include 'COMMON.VAR'
10017       include 'COMMON.IOUNITS'
10018       include 'COMMON.DERIV'
10019       include 'COMMON.CONTROL'
10020       include 'COMMON.NAMES'
10021       include 'COMMON.FFIELD'
10022       include 'COMMON.LANGEVIN'
10023       include 'COMMON.SAXS'
10024 c
10025       double precision Esaxs_constr
10026       integer i,iint,j,k,l
10027       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
10028 #ifdef MPI
10029       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10030 #endif
10031       double precision dk,dijCASPH,dijSCSPH,
10032      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10033      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10034      & auxX,auxX1,Cnorm
10035 c  SAXS restraint penalty function
10036 #ifdef DEBUG
10037       write(iout,*) "------- SAXS penalty function start -------"
10038       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10039      & " isaxs_end",isaxs_end
10040       write (iout,*) "nnt",nnt," ntc",nct
10041       do i=nnt,nct
10042         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10043      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10044       enddo
10045       do i=nnt,nct
10046         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10047       enddo
10048 #endif
10049       Esaxs_constr = 0.0d0
10050       logPtot=0.0d0
10051       do j=isaxs_start,isaxs_end
10052         Pcalc_=0.0d0
10053         do i=1,nres
10054           do l=1,3
10055             PgradC(l,i)=0.0d0
10056             PgradX(l,i)=0.0d0
10057           enddo
10058         enddo
10059         do i=nnt,nct
10060           dijCASPH=0.0d0
10061           dijSCSPH=0.0d0
10062           do l=1,3
10063             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10064           enddo
10065           if (itype(i).ne.10) then
10066           do l=1,3
10067             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10068           enddo
10069           endif
10070           sigma2CA=2.0d0/pstok**2
10071           sigma2SC=4.0d0/restok(itype(i))**2
10072           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10073           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10074           Pcalc_ = Pcalc_+expCASPH+expSCSPH
10075 #ifdef DEBUG
10076           write(*,*) "processor i j Pcalc",
10077      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
10078 #endif
10079           CASPHgrad = sigma2CA*expCASPH
10080           SCSPHgrad = sigma2SC*expSCSPH
10081           do l=1,3
10082             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10083             PgradX(l,i) = PgradX(l,i) + aux
10084             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10085           enddo ! l
10086         enddo ! i
10087         do i=nnt,nct
10088           do l=1,3
10089             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
10090             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
10091           enddo
10092         enddo
10093         logPtot = logPtot - dlog(Pcalc_)
10094 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
10095 c     &    " logPtot",logPtot
10096       enddo ! j
10097 #ifdef MPI
10098       if (nfgtasks.gt.1) then
10099 c        write (iout,*) "logPtot before reduction",logPtot
10100         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10101      &    MPI_SUM,king,FG_COMM,IERR)
10102         logPtot = logPtot_
10103 c        write (iout,*) "logPtot after reduction",logPtot
10104         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10105      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10106         if (fg_rank.eq.king) then
10107           do i=1,nres
10108             do l=1,3
10109               gsaxsC(l,i) = gsaxsC_(l,i)
10110             enddo
10111           enddo
10112         endif
10113         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10114      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10115         if (fg_rank.eq.king) then
10116           do i=1,nres
10117             do l=1,3
10118               gsaxsX(l,i) = gsaxsX_(l,i)
10119             enddo
10120           enddo
10121         endif
10122       endif
10123 #endif
10124       Esaxs_constr = logPtot
10125       return
10126       end
10127 C--------------------------------------------------------------------------
10128 c MODELLER restraint function
10129       subroutine e_modeller(ehomology_constr)
10130       implicit real*8 (a-h,o-z)
10131       include 'DIMENSIONS'
10132       integer nnn, i, j, k, ki, irec, l
10133       integer katy, odleglosci, test7
10134       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
10135       real*8 distance(max_template),distancek(max_template),
10136      &    min_odl,godl(max_template),dih_diff(max_template)
10137
10138 c
10139 c     FP - 30/10/2014 Temporary specifications for homology restraints
10140 c
10141       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
10142      &                 sgtheta
10143       double precision, dimension (maxres) :: guscdiff,usc_diff
10144       double precision, dimension (max_template) ::
10145      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
10146      &           theta_diff
10147
10148       include 'COMMON.SBRIDGE'
10149       include 'COMMON.CHAIN'
10150       include 'COMMON.GEO'
10151       include 'COMMON.DERIV'
10152       include 'COMMON.LOCAL'
10153       include 'COMMON.INTERACT'
10154       include 'COMMON.VAR'
10155       include 'COMMON.IOUNITS'
10156       include 'COMMON.CONTROL'
10157       include 'COMMON.HOMRESTR'
10158       include 'COMMON.HOMOLOGY'
10159       include 'COMMON.SETUP'
10160       include 'COMMON.NAMES'
10161
10162       do i=1,max_template
10163         distancek(i)=9999999.9
10164       enddo
10165
10166       odleg=0.0d0
10167
10168 c Pseudo-energy and gradient from homology restraints (MODELLER-like
10169 c function)
10170 C AL 5/2/14 - Introduce list of restraints
10171 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
10172 #ifdef DEBUG
10173       write(iout,*) "------- dist restrs start -------"
10174 #endif
10175       do ii = link_start_homo,link_end_homo
10176          i = ires_homo(ii)
10177          j = jres_homo(ii)
10178          dij=dist(i,j)
10179 c        write (iout,*) "dij(",i,j,") =",dij
10180          nexl=0
10181          do k=1,constr_homology
10182            if(.not.l_homo(k,ii)) then
10183               nexl=nexl+1
10184               cycle
10185            endif
10186            distance(k)=odl(k,ii)-dij
10187 c          write (iout,*) "distance(",k,") =",distance(k)
10188 c
10189 c          For Gaussian-type Urestr
10190 c
10191            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
10192 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
10193 c          write (iout,*) "distancek(",k,") =",distancek(k)
10194 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
10195 c
10196 c          For Lorentzian-type Urestr
10197 c
10198            if (waga_dist.lt.0.0d0) then
10199               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10200               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10201      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10202            endif
10203          enddo
10204
10205 c         min_odl=minval(distancek)
10206          if (nexl.gt.0) then
10207            min_odl=0.0d0
10208          else
10209            do kk=1,constr_homology
10210             if(l_homo(kk,ii)) then
10211               min_odl=distancek(kk)
10212               exit
10213             endif
10214            enddo
10215            do kk=1,constr_homology
10216             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10217      &              min_odl=distancek(kk)
10218            enddo
10219          endif
10220
10221 c        write (iout,* )"min_odl",min_odl
10222 #ifdef DEBUG
10223          write (iout,*) "ij dij",i,j,dij
10224          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10225          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10226          write (iout,* )"min_odl",min_odl
10227 #endif
10228 #ifdef OLDRESTR
10229          odleg2=0.0d0
10230 #else
10231          if (waga_dist.ge.0.0d0) then
10232            odleg2=nexl
10233          else
10234            odleg2=0.0d0
10235          endif
10236 #endif
10237          do k=1,constr_homology
10238 c Nie wiem po co to liczycie jeszcze raz!
10239 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10240 c     &              (2*(sigma_odl(i,j,k))**2))
10241            if(.not.l_homo(k,ii)) cycle
10242            if (waga_dist.ge.0.0d0) then
10243 c
10244 c          For Gaussian-type Urestr
10245 c
10246             godl(k)=dexp(-distancek(k)+min_odl)
10247             odleg2=odleg2+godl(k)
10248 c
10249 c          For Lorentzian-type Urestr
10250 c
10251            else
10252             odleg2=odleg2+distancek(k)
10253            endif
10254
10255 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10256 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10257 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10258 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10259
10260          enddo
10261 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10262 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10263 #ifdef DEBUG
10264          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10265          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10266 #endif
10267            if (waga_dist.ge.0.0d0) then
10268 c
10269 c          For Gaussian-type Urestr
10270 c
10271               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10272 c
10273 c          For Lorentzian-type Urestr
10274 c
10275            else
10276               odleg=odleg+odleg2/constr_homology
10277            endif
10278 c
10279 #ifdef GRAD
10280 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10281 c Gradient
10282 c
10283 c          For Gaussian-type Urestr
10284 c
10285          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10286          sum_sgodl=0.0d0
10287          do k=1,constr_homology
10288 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10289 c     &           *waga_dist)+min_odl
10290 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10291 c
10292          if(.not.l_homo(k,ii)) cycle
10293          if (waga_dist.ge.0.0d0) then
10294 c          For Gaussian-type Urestr
10295 c
10296            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10297 c
10298 c          For Lorentzian-type Urestr
10299 c
10300          else
10301            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10302      &           sigma_odlir(k,ii)**2)**2)
10303          endif
10304            sum_sgodl=sum_sgodl+sgodl
10305
10306 c            sgodl2=sgodl2+sgodl
10307 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10308 c      write(iout,*) "constr_homology=",constr_homology
10309 c      write(iout,*) i, j, k, "TEST K"
10310          enddo
10311          if (waga_dist.ge.0.0d0) then
10312 c
10313 c          For Gaussian-type Urestr
10314 c
10315             grad_odl3=waga_homology(iset)*waga_dist
10316      &                *sum_sgodl/(sum_godl*dij)
10317 c
10318 c          For Lorentzian-type Urestr
10319 c
10320          else
10321 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10322 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10323             grad_odl3=-waga_homology(iset)*waga_dist*
10324      &                sum_sgodl/(constr_homology*dij)
10325          endif
10326 c
10327 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10328
10329
10330 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10331 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10332 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10333
10334 ccc      write(iout,*) godl, sgodl, grad_odl3
10335
10336 c          grad_odl=grad_odl+grad_odl3
10337
10338          do jik=1,3
10339             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10340 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10341 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10342 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10343             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10344             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10345 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10346 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10347 c         if (i.eq.25.and.j.eq.27) then
10348 c         write(iout,*) "jik",jik,"i",i,"j",j
10349 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10350 c         write(iout,*) "grad_odl3",grad_odl3
10351 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10352 c         write(iout,*) "ggodl",ggodl
10353 c         write(iout,*) "ghpbc(",jik,i,")",
10354 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10355 c     &                 ghpbc(jik,j)
10356 c         endif
10357          enddo
10358 #endif
10359 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10360 ccc     & dLOG(odleg2),"-odleg=", -odleg
10361
10362       enddo ! ii-loop for dist
10363 #ifdef DEBUG
10364       write(iout,*) "------- dist restrs end -------"
10365 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10366 c    &     waga_d.eq.1.0d0) call sum_gradient
10367 #endif
10368 c Pseudo-energy and gradient from dihedral-angle restraints from
10369 c homology templates
10370 c      write (iout,*) "End of distance loop"
10371 c      call flush(iout)
10372       kat=0.0d0
10373 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10374 #ifdef DEBUG
10375       write(iout,*) "------- dih restrs start -------"
10376       do i=idihconstr_start_homo,idihconstr_end_homo
10377         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10378       enddo
10379 #endif
10380       do i=idihconstr_start_homo,idihconstr_end_homo
10381         kat2=0.0d0
10382 c        betai=beta(i,i+1,i+2,i+3)
10383         betai = phi(i)
10384 c       write (iout,*) "betai =",betai
10385         do k=1,constr_homology
10386           dih_diff(k)=pinorm(dih(k,i)-betai)
10387 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10388 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10389 c     &                                   -(6.28318-dih_diff(i,k))
10390 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10391 c     &                                   6.28318+dih_diff(i,k)
10392 #ifdef OLD_DIHED
10393           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10394 #else
10395           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10396 #endif
10397 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10398           gdih(k)=dexp(kat3)
10399           kat2=kat2+gdih(k)
10400 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10401 c          write(*,*)""
10402         enddo
10403 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10404 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10405 #ifdef DEBUG
10406         write (iout,*) "i",i," betai",betai," kat2",kat2
10407         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10408 #endif
10409         if (kat2.le.1.0d-14) cycle
10410         kat=kat-dLOG(kat2/constr_homology)
10411 c       write (iout,*) "kat",kat ! sum of -ln-s
10412
10413 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10414 ccc     & dLOG(kat2), "-kat=", -kat
10415
10416 #ifdef GRAD
10417 c ----------------------------------------------------------------------
10418 c Gradient
10419 c ----------------------------------------------------------------------
10420
10421         sum_gdih=kat2
10422         sum_sgdih=0.0d0
10423         do k=1,constr_homology
10424 #ifdef OLD_DIHED
10425           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10426 #else
10427           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10428 #endif
10429 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10430           sum_sgdih=sum_sgdih+sgdih
10431         enddo
10432 c       grad_dih3=sum_sgdih/sum_gdih
10433         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10434
10435 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10436 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10437 ccc     & gloc(nphi+i-3,icg)
10438         gloc(i,icg)=gloc(i,icg)+grad_dih3
10439 c        if (i.eq.25) then
10440 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10441 c        endif
10442 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10443 ccc     & gloc(nphi+i-3,icg)
10444 #endif
10445       enddo ! i-loop for dih
10446 #ifdef DEBUG
10447       write(iout,*) "------- dih restrs end -------"
10448 #endif
10449
10450 c Pseudo-energy and gradient for theta angle restraints from
10451 c homology templates
10452 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10453 c adapted
10454
10455 c
10456 c     For constr_homology reference structures (FP)
10457 c
10458 c     Uconst_back_tot=0.0d0
10459       Eval=0.0d0
10460       Erot=0.0d0
10461 c     Econstr_back legacy
10462 #ifdef GRAD
10463       do i=1,nres
10464 c     do i=ithet_start,ithet_end
10465        dutheta(i)=0.0d0
10466 c     enddo
10467 c     do i=loc_start,loc_end
10468         do j=1,3
10469           duscdiff(j,i)=0.0d0
10470           duscdiffx(j,i)=0.0d0
10471         enddo
10472       enddo
10473 #endif
10474 c
10475 c     do iref=1,nref
10476 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10477 c     write (iout,*) "waga_theta",waga_theta
10478       if (waga_theta.gt.0.0d0) then
10479 #ifdef DEBUG
10480       write (iout,*) "usampl",usampl
10481       write(iout,*) "------- theta restrs start -------"
10482 c     do i=ithet_start,ithet_end
10483 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10484 c     enddo
10485 #endif
10486 c     write (iout,*) "maxres",maxres,"nres",nres
10487
10488       do i=ithet_start,ithet_end
10489 c
10490 c     do i=1,nfrag_back
10491 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10492 c
10493 c Deviation of theta angles wrt constr_homology ref structures
10494 c
10495         utheta_i=0.0d0 ! argument of Gaussian for single k
10496         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10497 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10498 c       over residues in a fragment
10499 c       write (iout,*) "theta(",i,")=",theta(i)
10500         do k=1,constr_homology
10501 c
10502 c         dtheta_i=theta(j)-thetaref(j,iref)
10503 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10504           theta_diff(k)=thetatpl(k,i)-theta(i)
10505 c
10506           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10507 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10508           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10509           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10510 c         Gradient for single Gaussian restraint in subr Econstr_back
10511 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10512 c
10513         enddo
10514 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10515 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10516
10517 c
10518 #ifdef GRAD
10519 c         Gradient for multiple Gaussian restraint
10520         sum_gtheta=gutheta_i
10521         sum_sgtheta=0.0d0
10522         do k=1,constr_homology
10523 c        New generalized expr for multiple Gaussian from Econstr_back
10524          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10525 c
10526 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10527           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10528         enddo
10529 c
10530 c       Final value of gradient using same var as in Econstr_back
10531         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10532      &               *waga_homology(iset)
10533 c       dutheta(i)=sum_sgtheta/sum_gtheta
10534 c
10535 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10536 #endif
10537         Eval=Eval-dLOG(gutheta_i/constr_homology)
10538 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10539 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10540 c       Uconst_back=Uconst_back+utheta(i)
10541       enddo ! (i-loop for theta)
10542 #ifdef DEBUG
10543       write(iout,*) "------- theta restrs end -------"
10544 #endif
10545       endif
10546 c
10547 c Deviation of local SC geometry
10548 c
10549 c Separation of two i-loops (instructed by AL - 11/3/2014)
10550 c
10551 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10552 c     write (iout,*) "waga_d",waga_d
10553
10554 #ifdef DEBUG
10555       write(iout,*) "------- SC restrs start -------"
10556       write (iout,*) "Initial duscdiff,duscdiffx"
10557       do i=loc_start,loc_end
10558         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10559      &                 (duscdiffx(jik,i),jik=1,3)
10560       enddo
10561 #endif
10562       do i=loc_start,loc_end
10563         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10564         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10565 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10566 c       write(iout,*) "xxtab, yytab, zztab"
10567 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10568         do k=1,constr_homology
10569 c
10570           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10571 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10572           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10573           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10574 c         write(iout,*) "dxx, dyy, dzz"
10575 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10576 c
10577           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10578 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10579 c         uscdiffk(k)=usc_diff(i)
10580           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10581           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10582 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10583 c     &      xxref(j),yyref(j),zzref(j)
10584         enddo
10585 c
10586 c       Gradient
10587 c
10588 c       Generalized expression for multiple Gaussian acc to that for a single
10589 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10590 c
10591 c       Original implementation
10592 c       sum_guscdiff=guscdiff(i)
10593 c
10594 c       sum_sguscdiff=0.0d0
10595 c       do k=1,constr_homology
10596 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10597 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10598 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10599 c       enddo
10600 c
10601 c       Implementation of new expressions for gradient (Jan. 2015)
10602 c
10603 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10604 #ifdef GRAD
10605         do k=1,constr_homology
10606 c
10607 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10608 c       before. Now the drivatives should be correct
10609 c
10610           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10611 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10612           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10613           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10614 c
10615 c         New implementation
10616 c
10617           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10618      &                 sigma_d(k,i) ! for the grad wrt r'
10619 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10620 c
10621 c
10622 c        New implementation
10623          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10624          do jik=1,3
10625             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10626      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10627      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10628             duscdiff(jik,i)=duscdiff(jik,i)+
10629      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10630      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10631             duscdiffx(jik,i)=duscdiffx(jik,i)+
10632      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10633      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10634 c
10635 #ifdef DEBUG
10636              write(iout,*) "jik",jik,"i",i
10637              write(iout,*) "dxx, dyy, dzz"
10638              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10639              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10640 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10641 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10642 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10643 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10644 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10645 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10646 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10647 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10648 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10649 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10650 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10651 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10652 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10653 c            endif
10654 #endif
10655          enddo
10656         enddo
10657 #endif
10658 c
10659 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10660 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10661 c
10662 c        write (iout,*) i," uscdiff",uscdiff(i)
10663 c
10664 c Put together deviations from local geometry
10665
10666 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10667 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10668         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10669 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10670 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10671 c       Uconst_back=Uconst_back+usc_diff(i)
10672 c
10673 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10674 c
10675 c     New implment: multiplied by sum_sguscdiff
10676 c
10677
10678       enddo ! (i-loop for dscdiff)
10679
10680 c      endif
10681
10682 #ifdef DEBUG
10683       write(iout,*) "------- SC restrs end -------"
10684         write (iout,*) "------ After SC loop in e_modeller ------"
10685         do i=loc_start,loc_end
10686          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10687          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10688         enddo
10689       if (waga_theta.eq.1.0d0) then
10690       write (iout,*) "in e_modeller after SC restr end: dutheta"
10691       do i=ithet_start,ithet_end
10692         write (iout,*) i,dutheta(i)
10693       enddo
10694       endif
10695       if (waga_d.eq.1.0d0) then
10696       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10697       do i=1,nres
10698         write (iout,*) i,(duscdiff(j,i),j=1,3)
10699         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10700       enddo
10701       endif
10702 #endif
10703
10704 c Total energy from homology restraints
10705 #ifdef DEBUG
10706       write (iout,*) "odleg",odleg," kat",kat
10707       write (iout,*) "odleg",odleg," kat",kat
10708       write (iout,*) "Eval",Eval," Erot",Erot
10709       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10710       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10711       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10712 #endif
10713 c
10714 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10715 c
10716 c     ehomology_constr=odleg+kat
10717 c
10718 c     For Lorentzian-type Urestr
10719 c
10720
10721       if (waga_dist.ge.0.0d0) then
10722 c
10723 c          For Gaussian-type Urestr
10724 c
10725 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10726 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10727         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10728      &              waga_theta*Eval+waga_d*Erot
10729 c     write (iout,*) "ehomology_constr=",ehomology_constr
10730       else
10731 c
10732 c          For Lorentzian-type Urestr
10733 c
10734 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10735 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10736         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10737      &              waga_theta*Eval+waga_d*Erot
10738 c     write (iout,*) "ehomology_constr=",ehomology_constr
10739       endif
10740 #ifdef DEBUG
10741       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10742      & "Eval",waga_theta,eval,
10743      &   "Erot",waga_d,Erot
10744       write (iout,*) "ehomology_constr",ehomology_constr
10745 #endif
10746       return
10747
10748   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10749   747 format(a12,i4,i4,i4,f8.3,f8.3)
10750   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10751   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10752   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10753      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10754       end