source/cluster/wham/src-HCD/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         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1779           iti = itype2loc(itype(i-2))
1780         else
1781           iti=nloctyp
1782         endif
1783 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1784         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1785           iti1 = itype2loc(itype(i-1))
1786         else
1787           iti1=nloctyp
1788         endif
1789 #ifdef NEWCORR
1790         cost1=dcos(theta(i-1))
1791         sint1=dsin(theta(i-1))
1792         sint1sq=sint1*sint1
1793         sint1cub=sint1sq*sint1
1794         sint1cost1=2*sint1*cost1
1795 #ifdef DEBUG
1796         write (iout,*) "bnew1",i,iti
1797         write (iout,*) (bnew1(k,1,iti),k=1,3)
1798         write (iout,*) (bnew1(k,2,iti),k=1,3)
1799         write (iout,*) "bnew2",i,iti
1800         write (iout,*) (bnew2(k,1,iti),k=1,3)
1801         write (iout,*) (bnew2(k,2,iti),k=1,3)
1802 #endif
1803         do k=1,2
1804           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1805           b1(k,i-2)=sint1*b1k
1806           gtb1(k,i-2)=cost1*b1k-sint1sq*
1807      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1808           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1809           b2(k,i-2)=sint1*b2k
1810           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1811      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1812         enddo
1813         do k=1,2
1814           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1815           cc(1,k,i-2)=sint1sq*aux
1816           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1817      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1818           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1819           dd(1,k,i-2)=sint1sq*aux
1820           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1821      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1822         enddo
1823         cc(2,1,i-2)=cc(1,2,i-2)
1824         cc(2,2,i-2)=-cc(1,1,i-2)
1825         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1826         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1827         dd(2,1,i-2)=dd(1,2,i-2)
1828         dd(2,2,i-2)=-dd(1,1,i-2)
1829         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1830         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1831         do k=1,2
1832           do l=1,2
1833             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1834             EE(l,k,i-2)=sint1sq*aux
1835             if (calc_grad)
1836      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1837           enddo
1838         enddo
1839         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1840         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1841         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1842         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1843         if (calc_grad) then
1844         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1845         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1846         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1847         endif
1848 c        b1tilde(1,i-2)=b1(1,i-2)
1849 c        b1tilde(2,i-2)=-b1(2,i-2)
1850 c        b2tilde(1,i-2)=b2(1,i-2)
1851 c        b2tilde(2,i-2)=-b2(2,i-2)
1852 #ifdef DEBUG
1853         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1854         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1855         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1856         write (iout,*) 'theta=', theta(i-1)
1857 #endif
1858 #else
1859 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1860 c          iti = itype2loc(itype(i-2))
1861 c        else
1862 c          iti=nloctyp
1863 c        endif
1864 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1865 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1866 c          iti1 = itype2loc(itype(i-1))
1867 c        else
1868 c          iti1=nloctyp
1869 c        endif
1870         b1(1,i-2)=b(3,iti)
1871         b1(2,i-2)=b(5,iti)
1872         b2(1,i-2)=b(2,iti)
1873         b2(2,i-2)=b(4,iti)
1874         do k=1,2
1875           do l=1,2
1876            CC(k,l,i-2)=ccold(k,l,iti)
1877            DD(k,l,i-2)=ddold(k,l,iti)
1878            EE(k,l,i-2)=eeold(k,l,iti)
1879           enddo
1880         enddo
1881 #endif
1882         b1tilde(1,i-2)= b1(1,i-2)
1883         b1tilde(2,i-2)=-b1(2,i-2)
1884         b2tilde(1,i-2)= b2(1,i-2)
1885         b2tilde(2,i-2)=-b2(2,i-2)
1886 c
1887         Ctilde(1,1,i-2)= CC(1,1,i-2)
1888         Ctilde(1,2,i-2)= CC(1,2,i-2)
1889         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1890         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1891 c
1892         Dtilde(1,1,i-2)= DD(1,1,i-2)
1893         Dtilde(1,2,i-2)= DD(1,2,i-2)
1894         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1895         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1896 c        write(iout,*) "i",i," iti",iti
1897 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1898 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1899       enddo
1900       do i=3,nres+1
1901         if (i .lt. nres+1) then
1902           sin1=dsin(phi(i))
1903           cos1=dcos(phi(i))
1904           sintab(i-2)=sin1
1905           costab(i-2)=cos1
1906           obrot(1,i-2)=cos1
1907           obrot(2,i-2)=sin1
1908           sin2=dsin(2*phi(i))
1909           cos2=dcos(2*phi(i))
1910           sintab2(i-2)=sin2
1911           costab2(i-2)=cos2
1912           obrot2(1,i-2)=cos2
1913           obrot2(2,i-2)=sin2
1914           Ug(1,1,i-2)=-cos1
1915           Ug(1,2,i-2)=-sin1
1916           Ug(2,1,i-2)=-sin1
1917           Ug(2,2,i-2)= cos1
1918           Ug2(1,1,i-2)=-cos2
1919           Ug2(1,2,i-2)=-sin2
1920           Ug2(2,1,i-2)=-sin2
1921           Ug2(2,2,i-2)= cos2
1922         else
1923           costab(i-2)=1.0d0
1924           sintab(i-2)=0.0d0
1925           obrot(1,i-2)=1.0d0
1926           obrot(2,i-2)=0.0d0
1927           obrot2(1,i-2)=0.0d0
1928           obrot2(2,i-2)=0.0d0
1929           Ug(1,1,i-2)=1.0d0
1930           Ug(1,2,i-2)=0.0d0
1931           Ug(2,1,i-2)=0.0d0
1932           Ug(2,2,i-2)=1.0d0
1933           Ug2(1,1,i-2)=0.0d0
1934           Ug2(1,2,i-2)=0.0d0
1935           Ug2(2,1,i-2)=0.0d0
1936           Ug2(2,2,i-2)=0.0d0
1937         endif
1938         if (i .gt. 3 .and. i .lt. nres+1) then
1939           obrot_der(1,i-2)=-sin1
1940           obrot_der(2,i-2)= cos1
1941           Ugder(1,1,i-2)= sin1
1942           Ugder(1,2,i-2)=-cos1
1943           Ugder(2,1,i-2)=-cos1
1944           Ugder(2,2,i-2)=-sin1
1945           dwacos2=cos2+cos2
1946           dwasin2=sin2+sin2
1947           obrot2_der(1,i-2)=-dwasin2
1948           obrot2_der(2,i-2)= dwacos2
1949           Ug2der(1,1,i-2)= dwasin2
1950           Ug2der(1,2,i-2)=-dwacos2
1951           Ug2der(2,1,i-2)=-dwacos2
1952           Ug2der(2,2,i-2)=-dwasin2
1953         else
1954           obrot_der(1,i-2)=0.0d0
1955           obrot_der(2,i-2)=0.0d0
1956           Ugder(1,1,i-2)=0.0d0
1957           Ugder(1,2,i-2)=0.0d0
1958           Ugder(2,1,i-2)=0.0d0
1959           Ugder(2,2,i-2)=0.0d0
1960           obrot2_der(1,i-2)=0.0d0
1961           obrot2_der(2,i-2)=0.0d0
1962           Ug2der(1,1,i-2)=0.0d0
1963           Ug2der(1,2,i-2)=0.0d0
1964           Ug2der(2,1,i-2)=0.0d0
1965           Ug2der(2,2,i-2)=0.0d0
1966         endif
1967 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1968         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1969           iti = itype2loc(itype(i-2))
1970         else
1971           iti=nloctyp
1972         endif
1973 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1974         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1975           iti1 = itype2loc(itype(i-1))
1976         else
1977           iti1=nloctyp
1978         endif
1979 cd        write (iout,*) '*******i',i,' iti1',iti
1980 cd        write (iout,*) 'b1',b1(:,iti)
1981 cd        write (iout,*) 'b2',b2(:,iti)
1982 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1983 c        if (i .gt. iatel_s+2) then
1984         if (i .gt. nnt+2) then
1985           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1986 #ifdef NEWCORR
1987           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1988 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1989 #endif
1990 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1991 c     &    EE(1,2,iti),EE(2,2,i)
1992           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1993           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1994 c          write(iout,*) "Macierz EUG",
1995 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1996 c     &    eug(2,2,i-2)
1997 #ifdef FOURBODY
1998           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1999      &    then
2000           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
2001           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
2002           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2003           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
2004           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
2005           endif
2006 #endif
2007         else
2008           do k=1,2
2009             Ub2(k,i-2)=0.0d0
2010             Ctobr(k,i-2)=0.0d0
2011             Dtobr2(k,i-2)=0.0d0
2012             do l=1,2
2013               EUg(l,k,i-2)=0.0d0
2014               CUg(l,k,i-2)=0.0d0
2015               DUg(l,k,i-2)=0.0d0
2016               DtUg2(l,k,i-2)=0.0d0
2017             enddo
2018           enddo
2019         endif
2020         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2021         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2022         do k=1,2
2023           muder(k,i-2)=Ub2der(k,i-2)
2024         enddo
2025 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2026         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2027           if (itype(i-1).le.ntyp) then
2028             iti1 = itype2loc(itype(i-1))
2029           else
2030             iti1=nloctyp
2031           endif
2032         else
2033           iti1=nloctyp
2034         endif
2035         do k=1,2
2036           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2037         enddo
2038 #ifdef MUOUT
2039         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
2040      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
2041      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
2042      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
2043      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
2044      &      ((ee(l,k,i-2),l=1,2),k=1,2)
2045 #endif
2046 cd        write (iout,*) 'mu1',mu1(:,i-2)
2047 cd        write (iout,*) 'mu2',mu2(:,i-2)
2048 #ifdef FOURBODY
2049         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2050      &  then
2051         if (calc_grad) then
2052         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2053         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
2054         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2055         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
2056         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2057         endif
2058 C Vectors and matrices dependent on a single virtual-bond dihedral.
2059         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
2060         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2061         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
2062         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
2063         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
2064         if (calc_grad) then
2065         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2066         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
2067         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
2068         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
2069         endif
2070         endif
2071 #endif
2072       enddo
2073 #ifdef FOURBODY
2074 C Matrices dependent on two consecutive virtual-bond dihedrals.
2075 C The order of matrices is from left to right.
2076       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2077      &then
2078       do i=2,nres-1
2079         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2080         if (calc_grad) then
2081         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2082         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2083         endif
2084         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2085         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2086         if (calc_grad) then
2087         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2088         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2089         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2090         endif
2091       enddo
2092       endif
2093 #endif
2094       return
2095       end
2096 C--------------------------------------------------------------------------
2097       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2098 C
2099 C This subroutine calculates the average interaction energy and its gradient
2100 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2101 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2102 C The potential depends both on the distance of peptide-group centers and on
2103 C the orientation of the CA-CA virtual bonds.
2104 C
2105       implicit real*8 (a-h,o-z)
2106 #ifdef MPI
2107       include 'mpif.h'
2108 #endif
2109       include 'DIMENSIONS'
2110       include 'COMMON.CONTROL'
2111       include 'COMMON.IOUNITS'
2112       include 'COMMON.GEO'
2113       include 'COMMON.VAR'
2114       include 'COMMON.LOCAL'
2115       include 'COMMON.CHAIN'
2116       include 'COMMON.DERIV'
2117       include 'COMMON.INTERACT'
2118 #ifdef FOURBODY
2119       include 'COMMON.CONTACTS'
2120       include 'COMMON.CONTMAT'
2121 #endif
2122       include 'COMMON.CORRMAT'
2123       include 'COMMON.TORSION'
2124       include 'COMMON.VECTORS'
2125       include 'COMMON.FFIELD'
2126       include 'COMMON.TIME1'
2127       include 'COMMON.SPLITELE'
2128       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2129      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2130       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2131      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2132       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2133      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2134      &    num_conti,j1,j2
2135 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2136 #ifdef MOMENT
2137       double precision scal_el /1.0d0/
2138 #else
2139       double precision scal_el /0.5d0/
2140 #endif
2141 C 12/13/98
2142 C 13-go grudnia roku pamietnego...
2143       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2144      &                   0.0d0,1.0d0,0.0d0,
2145      &                   0.0d0,0.0d0,1.0d0/
2146 cd      write(iout,*) 'In EELEC'
2147 cd      do i=1,nloctyp
2148 cd        write(iout,*) 'Type',i
2149 cd        write(iout,*) 'B1',B1(:,i)
2150 cd        write(iout,*) 'B2',B2(:,i)
2151 cd        write(iout,*) 'CC',CC(:,:,i)
2152 cd        write(iout,*) 'DD',DD(:,:,i)
2153 cd        write(iout,*) 'EE',EE(:,:,i)
2154 cd      enddo
2155 cd      call check_vecgrad
2156 cd      stop
2157       if (icheckgrad.eq.1) then
2158         do i=1,nres-1
2159           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2160           do k=1,3
2161             dc_norm(k,i)=dc(k,i)*fac
2162           enddo
2163 c          write (iout,*) 'i',i,' fac',fac
2164         enddo
2165       endif
2166       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2167      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2168      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2169 c        call vec_and_deriv
2170 #ifdef TIMING
2171         time01=MPI_Wtime()
2172 #endif
2173         call set_matrices
2174 #ifdef TIMING
2175         time_mat=time_mat+MPI_Wtime()-time01
2176 #endif
2177       endif
2178 cd      do i=1,nres-1
2179 cd        write (iout,*) 'i=',i
2180 cd        do k=1,3
2181 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2182 cd        enddo
2183 cd        do k=1,3
2184 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2185 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2186 cd        enddo
2187 cd      enddo
2188       t_eelecij=0.0d0
2189       ees=0.0D0
2190       evdw1=0.0D0
2191       eel_loc=0.0d0
2192       eello_turn3=0.0d0
2193       eello_turn4=0.0d0
2194       ind=0
2195 #ifdef FOURBODY
2196       do i=1,nres
2197         num_cont_hb(i)=0
2198       enddo
2199 #endif
2200 cd      print '(a)','Enter EELEC'
2201 c      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2202 c      call flush(iout)
2203       do i=1,nres
2204         gel_loc_loc(i)=0.0d0
2205         gcorr_loc(i)=0.0d0
2206       enddo
2207 c
2208 c
2209 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2210 C
2211 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2212 C
2213 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2214       do i=iturn3_start,iturn3_end
2215 c        if (i.le.1) cycle
2216 C        write(iout,*) "tu jest i",i
2217         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2218 C changes suggested by Ana to avoid out of bounds
2219 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2220 c     & .or.((i+4).gt.nres)
2221 c     & .or.((i-1).le.0)
2222 C end of changes by Ana
2223 C dobra zmiana wycofana
2224      &  .or. itype(i+2).eq.ntyp1
2225      &  .or. itype(i+3).eq.ntyp1) cycle
2226 C Adam: Instructions below will switch off existing interactions
2227 c        if(i.gt.1)then
2228 c          if(itype(i-1).eq.ntyp1)cycle
2229 c        end if
2230 c        if(i.LT.nres-3)then
2231 c          if (itype(i+4).eq.ntyp1) cycle
2232 c        end if
2233         dxi=dc(1,i)
2234         dyi=dc(2,i)
2235         dzi=dc(3,i)
2236         dx_normi=dc_norm(1,i)
2237         dy_normi=dc_norm(2,i)
2238         dz_normi=dc_norm(3,i)
2239         xmedi=c(1,i)+0.5d0*dxi
2240         ymedi=c(2,i)+0.5d0*dyi
2241         zmedi=c(3,i)+0.5d0*dzi
2242           xmedi=mod(xmedi,boxxsize)
2243           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2244           ymedi=mod(ymedi,boxysize)
2245           if (ymedi.lt.0) ymedi=ymedi+boxysize
2246           zmedi=mod(zmedi,boxzsize)
2247           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2248         num_conti=0
2249         call eelecij(i,i+2,ees,evdw1,eel_loc)
2250         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2251 #ifdef FOURBODY
2252         num_cont_hb(i)=num_conti
2253 #endif
2254       enddo
2255       do i=iturn4_start,iturn4_end
2256         if (i.lt.1) cycle
2257         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2258 C changes suggested by Ana to avoid out of bounds
2259 c     & .or.((i+5).gt.nres)
2260 c     & .or.((i-1).le.0)
2261 C end of changes suggested by Ana
2262      &    .or. itype(i+3).eq.ntyp1
2263      &    .or. itype(i+4).eq.ntyp1
2264 c     &    .or. itype(i+5).eq.ntyp1
2265 c     &    .or. itype(i).eq.ntyp1
2266 c     &    .or. itype(i-1).eq.ntyp1
2267      &                             ) cycle
2268         dxi=dc(1,i)
2269         dyi=dc(2,i)
2270         dzi=dc(3,i)
2271         dx_normi=dc_norm(1,i)
2272         dy_normi=dc_norm(2,i)
2273         dz_normi=dc_norm(3,i)
2274         xmedi=c(1,i)+0.5d0*dxi
2275         ymedi=c(2,i)+0.5d0*dyi
2276         zmedi=c(3,i)+0.5d0*dzi
2277 C Return atom into box, boxxsize is size of box in x dimension
2278 c  194   continue
2279 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2280 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2281 C Condition for being inside the proper box
2282 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2283 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2284 c        go to 194
2285 c        endif
2286 c  195   continue
2287 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2288 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2289 C Condition for being inside the proper box
2290 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2291 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2292 c        go to 195
2293 c        endif
2294 c  196   continue
2295 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2296 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2297 C Condition for being inside the proper box
2298 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2299 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2300 c        go to 196
2301 c        endif
2302           xmedi=mod(xmedi,boxxsize)
2303           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2304           ymedi=mod(ymedi,boxysize)
2305           if (ymedi.lt.0) ymedi=ymedi+boxysize
2306           zmedi=mod(zmedi,boxzsize)
2307           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2308
2309 #ifdef FOURBODY
2310         num_conti=num_cont_hb(i)
2311 #endif
2312 c        write(iout,*) "JESTEM W PETLI"
2313         call eelecij(i,i+3,ees,evdw1,eel_loc)
2314         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2315      &   call eturn4(i,eello_turn4)
2316 #ifdef FOURBODY
2317         num_cont_hb(i)=num_conti
2318 #endif
2319       enddo   ! i
2320 C Loop over all neighbouring boxes
2321 C      do xshift=-1,1
2322 C      do yshift=-1,1
2323 C      do zshift=-1,1
2324 c
2325 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2326 c
2327 CTU KURWA
2328       do i=iatel_s,iatel_e
2329 C        do i=75,75
2330 c        if (i.le.1) cycle
2331         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2332 C changes suggested by Ana to avoid out of bounds
2333 c     & .or.((i+2).gt.nres)
2334 c     & .or.((i-1).le.0)
2335 C end of changes by Ana
2336 c     &  .or. itype(i+2).eq.ntyp1
2337 c     &  .or. itype(i-1).eq.ntyp1
2338      &                ) cycle
2339         dxi=dc(1,i)
2340         dyi=dc(2,i)
2341         dzi=dc(3,i)
2342         dx_normi=dc_norm(1,i)
2343         dy_normi=dc_norm(2,i)
2344         dz_normi=dc_norm(3,i)
2345         xmedi=c(1,i)+0.5d0*dxi
2346         ymedi=c(2,i)+0.5d0*dyi
2347         zmedi=c(3,i)+0.5d0*dzi
2348           xmedi=mod(xmedi,boxxsize)
2349           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2350           ymedi=mod(ymedi,boxysize)
2351           if (ymedi.lt.0) ymedi=ymedi+boxysize
2352           zmedi=mod(zmedi,boxzsize)
2353           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2354 C          xmedi=xmedi+xshift*boxxsize
2355 C          ymedi=ymedi+yshift*boxysize
2356 C          zmedi=zmedi+zshift*boxzsize
2357
2358 C Return tom into box, boxxsize is size of box in x dimension
2359 c  164   continue
2360 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2361 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2362 C Condition for being inside the proper box
2363 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2364 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2365 c        go to 164
2366 c        endif
2367 c  165   continue
2368 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2369 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2370 C Condition for being inside the proper box
2371 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2372 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2373 c        go to 165
2374 c        endif
2375 c  166   continue
2376 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2377 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2378 cC Condition for being inside the proper box
2379 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2380 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2381 c        go to 166
2382 c        endif
2383
2384 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2385 #ifdef FOURBODY
2386         num_conti=num_cont_hb(i)
2387 #endif
2388 C I TU KURWA
2389         do j=ielstart(i),ielend(i)
2390 C          do j=16,17
2391 C          write (iout,*) i,j
2392 C         if (j.le.1) cycle
2393           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2394 C changes suggested by Ana to avoid out of bounds
2395 c     & .or.((j+2).gt.nres)
2396 c     & .or.((j-1).le.0)
2397 C end of changes by Ana
2398 c     & .or.itype(j+2).eq.ntyp1
2399 c     & .or.itype(j-1).eq.ntyp1
2400      &) cycle
2401           call eelecij(i,j,ees,evdw1,eel_loc)
2402         enddo ! j
2403 #ifdef FOURBODY
2404         num_cont_hb(i)=num_conti
2405 #endif
2406       enddo   ! i
2407 C     enddo   ! zshift
2408 C      enddo   ! yshift
2409 C      enddo   ! xshift
2410
2411 c      write (iout,*) "Number of loop steps in EELEC:",ind
2412 cd      do i=1,nres
2413 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2414 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2415 cd      enddo
2416 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2417 ccc      eel_loc=eel_loc+eello_turn3
2418 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2419       return
2420       end
2421 C-------------------------------------------------------------------------------
2422       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2423       implicit real*8 (a-h,o-z)
2424       include 'DIMENSIONS'
2425 #ifdef MPI
2426       include "mpif.h"
2427 #endif
2428       include 'COMMON.CONTROL'
2429       include 'COMMON.IOUNITS'
2430       include 'COMMON.GEO'
2431       include 'COMMON.VAR'
2432       include 'COMMON.LOCAL'
2433       include 'COMMON.CHAIN'
2434       include 'COMMON.DERIV'
2435       include 'COMMON.INTERACT'
2436 #ifdef FOURBODY
2437       include 'COMMON.CONTACTS'
2438       include 'COMMON.CONTMAT'
2439 #endif
2440       include 'COMMON.CORRMAT'
2441       include 'COMMON.TORSION'
2442       include 'COMMON.VECTORS'
2443       include 'COMMON.FFIELD'
2444       include 'COMMON.TIME1'
2445       include 'COMMON.SPLITELE'
2446       include 'COMMON.SHIELD'
2447       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2448      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2449       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2450      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2451      &    gmuij2(4),gmuji2(4)
2452       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2453      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2454      &    num_conti,j1,j2
2455 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2456 #ifdef MOMENT
2457       double precision scal_el /1.0d0/
2458 #else
2459       double precision scal_el /0.5d0/
2460 #endif
2461 C 12/13/98
2462 C 13-go grudnia roku pamietnego...
2463       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2464      &                   0.0d0,1.0d0,0.0d0,
2465      &                   0.0d0,0.0d0,1.0d0/
2466        integer xshift,yshift,zshift
2467 c          time00=MPI_Wtime()
2468 cd      write (iout,*) "eelecij",i,j
2469 c          ind=ind+1
2470           iteli=itel(i)
2471           itelj=itel(j)
2472           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2473           aaa=app(iteli,itelj)
2474           bbb=bpp(iteli,itelj)
2475           ael6i=ael6(iteli,itelj)
2476           ael3i=ael3(iteli,itelj)
2477           dxj=dc(1,j)
2478           dyj=dc(2,j)
2479           dzj=dc(3,j)
2480           dx_normj=dc_norm(1,j)
2481           dy_normj=dc_norm(2,j)
2482           dz_normj=dc_norm(3,j)
2483 C          xj=c(1,j)+0.5D0*dxj-xmedi
2484 C          yj=c(2,j)+0.5D0*dyj-ymedi
2485 C          zj=c(3,j)+0.5D0*dzj-zmedi
2486           xj=c(1,j)+0.5D0*dxj
2487           yj=c(2,j)+0.5D0*dyj
2488           zj=c(3,j)+0.5D0*dzj
2489           xj=mod(xj,boxxsize)
2490           if (xj.lt.0) xj=xj+boxxsize
2491           yj=mod(yj,boxysize)
2492           if (yj.lt.0) yj=yj+boxysize
2493           zj=mod(zj,boxzsize)
2494           if (zj.lt.0) zj=zj+boxzsize
2495           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2496       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2497       xj_safe=xj
2498       yj_safe=yj
2499       zj_safe=zj
2500       isubchap=0
2501       do xshift=-1,1
2502       do yshift=-1,1
2503       do zshift=-1,1
2504           xj=xj_safe+xshift*boxxsize
2505           yj=yj_safe+yshift*boxysize
2506           zj=zj_safe+zshift*boxzsize
2507           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2508           if(dist_temp.lt.dist_init) then
2509             dist_init=dist_temp
2510             xj_temp=xj
2511             yj_temp=yj
2512             zj_temp=zj
2513             isubchap=1
2514           endif
2515        enddo
2516        enddo
2517        enddo
2518        if (isubchap.eq.1) then
2519           xj=xj_temp-xmedi
2520           yj=yj_temp-ymedi
2521           zj=zj_temp-zmedi
2522        else
2523           xj=xj_safe-xmedi
2524           yj=yj_safe-ymedi
2525           zj=zj_safe-zmedi
2526        endif
2527 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2528 c  174   continue
2529 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2530 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2531 C Condition for being inside the proper box
2532 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2533 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2534 c        go to 174
2535 c        endif
2536 c  175   continue
2537 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2538 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2539 C Condition for being inside the proper box
2540 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2541 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2542 c        go to 175
2543 c        endif
2544 c  176   continue
2545 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2546 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2547 C Condition for being inside the proper box
2548 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2549 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2550 c        go to 176
2551 c        endif
2552 C        endif !endPBC condintion
2553 C        xj=xj-xmedi
2554 C        yj=yj-ymedi
2555 C        zj=zj-zmedi
2556           rij=xj*xj+yj*yj+zj*zj
2557
2558           sss=sscale(sqrt(rij))
2559           if (sss.eq.0.0d0) return
2560           sssgrad=sscagrad(sqrt(rij))
2561 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2562 c     &       " rlamb",rlamb," sss",sss
2563 c            if (sss.gt.0.0d0) then
2564           rrmij=1.0D0/rij
2565           rij=dsqrt(rij)
2566           rmij=1.0D0/rij
2567           r3ij=rrmij*rmij
2568           r6ij=r3ij*r3ij
2569           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2570           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2571           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2572           fac=cosa-3.0D0*cosb*cosg
2573           ev1=aaa*r6ij*r6ij
2574 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2575           if (j.eq.i+2) ev1=scal_el*ev1
2576           ev2=bbb*r6ij
2577           fac3=ael6i*r6ij
2578           fac4=ael3i*r3ij
2579           evdwij=(ev1+ev2)
2580           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2581           el2=fac4*fac
2582 C MARYSIA
2583 C          eesij=(el1+el2)
2584 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2585           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2586           if (shield_mode.gt.0) then
2587 C          fac_shield(i)=0.4
2588 C          fac_shield(j)=0.6
2589           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2590           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2591           eesij=(el1+el2)
2592           ees=ees+eesij
2593           else
2594           fac_shield(i)=1.0
2595           fac_shield(j)=1.0
2596           eesij=(el1+el2)
2597           ees=ees+eesij
2598           endif
2599           evdw1=evdw1+evdwij*sss
2600 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2601 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2602 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2603 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2604
2605           if (energy_dec) then
2606               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2607      &'evdw1',i,j,evdwij
2608      &,iteli,itelj,aaa,evdw1,sss
2609               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2610      &fac_shield(i),fac_shield(j)
2611           endif
2612
2613 C
2614 C Calculate contributions to the Cartesian gradient.
2615 C
2616 #ifdef SPLITELE
2617           facvdw=-6*rrmij*(ev1+evdwij)*sss
2618           facel=-3*rrmij*(el1+eesij)
2619           fac1=fac
2620           erij(1)=xj*rmij
2621           erij(2)=yj*rmij
2622           erij(3)=zj*rmij
2623
2624 *
2625 * Radial derivatives. First process both termini of the fragment (i,j)
2626 *
2627           if (calc_grad) then
2628           ggg(1)=facel*xj
2629           ggg(2)=facel*yj
2630           ggg(3)=facel*zj
2631           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2632      &  (shield_mode.gt.0)) then
2633 C          print *,i,j
2634           do ilist=1,ishield_list(i)
2635            iresshield=shield_list(ilist,i)
2636            do k=1,3
2637            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2638      &      *2.0
2639            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2640      &              rlocshield
2641      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2642             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2643 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2644 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2645 C             if (iresshield.gt.i) then
2646 C               do ishi=i+1,iresshield-1
2647 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2648 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2649 C
2650 C              enddo
2651 C             else
2652 C               do ishi=iresshield,i
2653 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2654 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2655 C
2656 C               enddo
2657 C              endif
2658            enddo
2659           enddo
2660           do ilist=1,ishield_list(j)
2661            iresshield=shield_list(ilist,j)
2662            do k=1,3
2663            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2664      &     *2.0
2665            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2666      &              rlocshield
2667      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2668            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2669
2670 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2671 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2672 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2673 C             if (iresshield.gt.j) then
2674 C               do ishi=j+1,iresshield-1
2675 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2676 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2677 C
2678 C               enddo
2679 C            else
2680 C               do ishi=iresshield,j
2681 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2682 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2683 C               enddo
2684 C              endif
2685            enddo
2686           enddo
2687
2688           do k=1,3
2689             gshieldc(k,i)=gshieldc(k,i)+
2690      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2691             gshieldc(k,j)=gshieldc(k,j)+
2692      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2693             gshieldc(k,i-1)=gshieldc(k,i-1)+
2694      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2695             gshieldc(k,j-1)=gshieldc(k,j-1)+
2696      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2697
2698            enddo
2699            endif
2700 c          do k=1,3
2701 c            ghalf=0.5D0*ggg(k)
2702 c            gelc(k,i)=gelc(k,i)+ghalf
2703 c            gelc(k,j)=gelc(k,j)+ghalf
2704 c          enddo
2705 c 9/28/08 AL Gradient compotents will be summed only at the end
2706 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2707           do k=1,3
2708             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2709 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2710             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2711 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2712 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2713 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2714 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2715 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2716           enddo
2717 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2718
2719 *
2720 * Loop over residues i+1 thru j-1.
2721 *
2722 cgrad          do k=i+1,j-1
2723 cgrad            do l=1,3
2724 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2725 cgrad            enddo
2726 cgrad          enddo
2727           if (sss.gt.0.0) then
2728           facvdw=facvdw+sssgrad*rmij*evdwij
2729           ggg(1)=facvdw*xj
2730           ggg(2)=facvdw*yj
2731           ggg(3)=facvdw*zj
2732           else
2733           ggg(1)=0.0
2734           ggg(2)=0.0
2735           ggg(3)=0.0
2736           endif
2737 c          do k=1,3
2738 c            ghalf=0.5D0*ggg(k)
2739 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2740 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2741 c          enddo
2742 c 9/28/08 AL Gradient compotents will be summed only at the end
2743           do k=1,3
2744             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2745             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2746           enddo
2747 *
2748 * Loop over residues i+1 thru j-1.
2749 *
2750 cgrad          do k=i+1,j-1
2751 cgrad            do l=1,3
2752 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2753 cgrad            enddo
2754 cgrad          enddo
2755           endif ! calc_grad
2756 #else
2757 C MARYSIA
2758           facvdw=(ev1+evdwij)
2759           facel=(el1+eesij)
2760           fac1=fac
2761           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
2762      &       +(evdwij+eesij)*sssgrad*rrmij
2763           erij(1)=xj*rmij
2764           erij(2)=yj*rmij
2765           erij(3)=zj*rmij
2766 *
2767 * Radial derivatives. First process both termini of the fragment (i,j)
2768 *
2769           if (calc_grad) then
2770           ggg(1)=fac*xj
2771 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2772           ggg(2)=fac*yj
2773 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2774           ggg(3)=fac*zj
2775 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2776 c          do k=1,3
2777 c            ghalf=0.5D0*ggg(k)
2778 c            gelc(k,i)=gelc(k,i)+ghalf
2779 c            gelc(k,j)=gelc(k,j)+ghalf
2780 c          enddo
2781 c 9/28/08 AL Gradient compotents will be summed only at the end
2782           do k=1,3
2783             gelc_long(k,j)=gelc(k,j)+ggg(k)
2784             gelc_long(k,i)=gelc(k,i)-ggg(k)
2785           enddo
2786 *
2787 * Loop over residues i+1 thru j-1.
2788 *
2789 cgrad          do k=i+1,j-1
2790 cgrad            do l=1,3
2791 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2792 cgrad            enddo
2793 cgrad          enddo
2794 c 9/28/08 AL Gradient compotents will be summed only at the end
2795           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2796           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2797           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2798           do k=1,3
2799             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2800             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2801           enddo
2802           endif ! calc_grad
2803 #endif
2804 *
2805 * Angular part
2806 *
2807           if (calc_grad) then
2808           ecosa=2.0D0*fac3*fac1+fac4
2809           fac4=-3.0D0*fac4
2810           fac3=-6.0D0*fac3
2811           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2812           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2813           do k=1,3
2814             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2815             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2816           enddo
2817 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2818 cd   &          (dcosg(k),k=1,3)
2819           do k=1,3
2820             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2821      &      fac_shield(i)**2*fac_shield(j)**2
2822           enddo
2823 c          do k=1,3
2824 c            ghalf=0.5D0*ggg(k)
2825 c            gelc(k,i)=gelc(k,i)+ghalf
2826 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2827 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2828 c            gelc(k,j)=gelc(k,j)+ghalf
2829 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2830 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2831 c          enddo
2832 cgrad          do k=i+1,j-1
2833 cgrad            do l=1,3
2834 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2835 cgrad            enddo
2836 cgrad          enddo
2837 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2838           do k=1,3
2839             gelc(k,i)=gelc(k,i)
2840      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2841      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2842      &           *fac_shield(i)**2*fac_shield(j)**2
2843             gelc(k,j)=gelc(k,j)
2844      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2845      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2846      &           *fac_shield(i)**2*fac_shield(j)**2
2847             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2848             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2849           enddo
2850 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2851
2852 C MARYSIA
2853 c          endif !sscale
2854           endif ! calc_grad
2855           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2856      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2857      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2858 C
2859 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2860 C   energy of a peptide unit is assumed in the form of a second-order
2861 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2862 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2863 C   are computed for EVERY pair of non-contiguous peptide groups.
2864 C
2865
2866           if (j.lt.nres-1) then
2867             j1=j+1
2868             j2=j-1
2869           else
2870             j1=j-1
2871             j2=j-2
2872           endif
2873           kkk=0
2874           lll=0
2875           do k=1,2
2876             do l=1,2
2877               kkk=kkk+1
2878               muij(kkk)=mu(k,i)*mu(l,j)
2879 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2880 #ifdef NEWCORR
2881              if (calc_grad) then
2882              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2883 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2884              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2885              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2886 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2887              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2888              endif
2889 #endif
2890             enddo
2891           enddo
2892 #ifdef DEBUG
2893           write (iout,*) 'EELEC: i',i,' j',j
2894           write (iout,*) 'j',j,' j1',j1,' j2',j2
2895           write(iout,*) 'muij',muij
2896           write (iout,*) "uy",uy(:,i)
2897           write (iout,*) "uz",uz(:,j)
2898           write (iout,*) "erij",erij
2899 #endif
2900           ury=scalar(uy(1,i),erij)
2901           urz=scalar(uz(1,i),erij)
2902           vry=scalar(uy(1,j),erij)
2903           vrz=scalar(uz(1,j),erij)
2904           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2905           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2906           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2907           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2908           fac=dsqrt(-ael6i)*r3ij
2909           a22=a22*fac
2910           a23=a23*fac
2911           a32=a32*fac
2912           a33=a33*fac
2913 cd          write (iout,'(4i5,4f10.5)')
2914 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2915 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2916 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2917 cd     &      uy(:,j),uz(:,j)
2918 cd          write (iout,'(4f10.5)')
2919 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2920 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2921 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2922 cd           write (iout,'(9f10.5/)')
2923 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2924 C Derivatives of the elements of A in virtual-bond vectors
2925           if (calc_grad) then
2926           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2927           do k=1,3
2928             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2929             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2930             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2931             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2932             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2933             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2934             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2935             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2936             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2937             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2938             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2939             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2940           enddo
2941 C Compute radial contributions to the gradient
2942           facr=-3.0d0*rrmij
2943           a22der=a22*facr
2944           a23der=a23*facr
2945           a32der=a32*facr
2946           a33der=a33*facr
2947           agg(1,1)=a22der*xj
2948           agg(2,1)=a22der*yj
2949           agg(3,1)=a22der*zj
2950           agg(1,2)=a23der*xj
2951           agg(2,2)=a23der*yj
2952           agg(3,2)=a23der*zj
2953           agg(1,3)=a32der*xj
2954           agg(2,3)=a32der*yj
2955           agg(3,3)=a32der*zj
2956           agg(1,4)=a33der*xj
2957           agg(2,4)=a33der*yj
2958           agg(3,4)=a33der*zj
2959 C Add the contributions coming from er
2960           fac3=-3.0d0*fac
2961           do k=1,3
2962             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2963             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2964             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2965             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2966           enddo
2967           do k=1,3
2968 C Derivatives in DC(i)
2969 cgrad            ghalf1=0.5d0*agg(k,1)
2970 cgrad            ghalf2=0.5d0*agg(k,2)
2971 cgrad            ghalf3=0.5d0*agg(k,3)
2972 cgrad            ghalf4=0.5d0*agg(k,4)
2973             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2974      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2975             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2976      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2977             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2978      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2979             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2980      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2981 C Derivatives in DC(i+1)
2982             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2983      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2984             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2985      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2986             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2987      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2988             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2989      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2990 C Derivatives in DC(j)
2991             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2992      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2993             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2994      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2995             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2996      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2997             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2998      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2999 C Derivatives in DC(j+1) or DC(nres-1)
3000             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3001      &      -3.0d0*vryg(k,3)*ury)
3002             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3003      &      -3.0d0*vrzg(k,3)*ury)
3004             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3005      &      -3.0d0*vryg(k,3)*urz)
3006             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3007      &      -3.0d0*vrzg(k,3)*urz)
3008 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3009 cgrad              do l=1,4
3010 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3011 cgrad              enddo
3012 cgrad            endif
3013           enddo
3014           endif ! calc_grad
3015           acipa(1,1)=a22
3016           acipa(1,2)=a23
3017           acipa(2,1)=a32
3018           acipa(2,2)=a33
3019           a22=-a22
3020           a23=-a23
3021           if (calc_grad) then
3022           do l=1,2
3023             do k=1,3
3024               agg(k,l)=-agg(k,l)
3025               aggi(k,l)=-aggi(k,l)
3026               aggi1(k,l)=-aggi1(k,l)
3027               aggj(k,l)=-aggj(k,l)
3028               aggj1(k,l)=-aggj1(k,l)
3029             enddo
3030           enddo
3031           endif ! calc_grad
3032           if (j.lt.nres-1) then
3033             a22=-a22
3034             a32=-a32
3035             do l=1,3,2
3036               do k=1,3
3037                 agg(k,l)=-agg(k,l)
3038                 aggi(k,l)=-aggi(k,l)
3039                 aggi1(k,l)=-aggi1(k,l)
3040                 aggj(k,l)=-aggj(k,l)
3041                 aggj1(k,l)=-aggj1(k,l)
3042               enddo
3043             enddo
3044           else
3045             a22=-a22
3046             a23=-a23
3047             a32=-a32
3048             a33=-a33
3049             do l=1,4
3050               do k=1,3
3051                 agg(k,l)=-agg(k,l)
3052                 aggi(k,l)=-aggi(k,l)
3053                 aggi1(k,l)=-aggi1(k,l)
3054                 aggj(k,l)=-aggj(k,l)
3055                 aggj1(k,l)=-aggj1(k,l)
3056               enddo
3057             enddo
3058           endif
3059           ENDIF ! WCORR
3060           IF (wel_loc.gt.0.0d0) THEN
3061 C Contribution to the local-electrostatic energy coming from the i-j pair
3062           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3063      &     +a33*muij(4)
3064 #ifdef DEBUG
3065           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
3066      &     " a33",a33
3067           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
3068      &     " wel_loc",wel_loc
3069 #endif
3070           if (shield_mode.eq.0) then
3071            fac_shield(i)=1.0
3072            fac_shield(j)=1.0
3073 C          else
3074 C           fac_shield(i)=0.4
3075 C           fac_shield(j)=0.6
3076           endif
3077           eel_loc_ij=eel_loc_ij
3078      &    *fac_shield(i)*fac_shield(j)
3079           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3080      &            'eelloc',i,j,eel_loc_ij
3081 c           if (eel_loc_ij.ne.0)
3082 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3083 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3084
3085           eel_loc=eel_loc+eel_loc_ij*sss
3086 C Now derivative over eel_loc
3087           if (calc_grad) then
3088           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3089      &  (shield_mode.gt.0)) then
3090 C          print *,i,j
3091
3092           do ilist=1,ishield_list(i)
3093            iresshield=shield_list(ilist,i)
3094            do k=1,3
3095            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
3096      &                                          /fac_shield(i)
3097 C     &      *2.0
3098            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3099      &              rlocshield
3100      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
3101             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3102      &      +rlocshield
3103            enddo
3104           enddo
3105           do ilist=1,ishield_list(j)
3106            iresshield=shield_list(ilist,j)
3107            do k=1,3
3108            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
3109      &                                       /fac_shield(j)
3110 C     &     *2.0
3111            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
3112      &              rlocshield
3113      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3114            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3115      &             +rlocshield
3116
3117            enddo
3118           enddo
3119
3120           do k=1,3
3121             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3122      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3123             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3124      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3125             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3126      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3127             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3128      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3129            enddo
3130            endif
3131
3132
3133 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3134 c     &                     ' eel_loc_ij',eel_loc_ij
3135 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3136 C Calculate patrial derivative for theta angle
3137 #ifdef NEWCORR
3138          geel_loc_ij=(a22*gmuij1(1)
3139      &     +a23*gmuij1(2)
3140      &     +a32*gmuij1(3)
3141      &     +a33*gmuij1(4))
3142      &    *fac_shield(i)*fac_shield(j)*sss
3143 c         write(iout,*) "derivative over thatai"
3144 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3145 c     &   a33*gmuij1(4)
3146          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3147      &      geel_loc_ij*wel_loc
3148 c         write(iout,*) "derivative over thatai-1"
3149 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3150 c     &   a33*gmuij2(4)
3151          geel_loc_ij=
3152      &     a22*gmuij2(1)
3153      &     +a23*gmuij2(2)
3154      &     +a32*gmuij2(3)
3155      &     +a33*gmuij2(4)
3156          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3157      &      geel_loc_ij*wel_loc
3158      &    *fac_shield(i)*fac_shield(j)*sss
3159
3160 c  Derivative over j residue
3161          geel_loc_ji=a22*gmuji1(1)
3162      &     +a23*gmuji1(2)
3163      &     +a32*gmuji1(3)
3164      &     +a33*gmuji1(4)
3165 c         write(iout,*) "derivative over thataj"
3166 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3167 c     &   a33*gmuji1(4)
3168
3169         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3170      &      geel_loc_ji*wel_loc
3171      &    *fac_shield(i)*fac_shield(j)
3172
3173          geel_loc_ji=
3174      &     +a22*gmuji2(1)
3175      &     +a23*gmuji2(2)
3176      &     +a32*gmuji2(3)
3177      &     +a33*gmuji2(4)
3178 c         write(iout,*) "derivative over thataj-1"
3179 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3180 c     &   a33*gmuji2(4)
3181          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3182      &      geel_loc_ji*wel_loc
3183      &    *fac_shield(i)*fac_shield(j)*sss
3184 #endif
3185 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3186
3187 C Partial derivatives in virtual-bond dihedral angles gamma
3188           if (i.gt.1)
3189      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3190      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3191      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3192      &    *fac_shield(i)*fac_shield(j)
3193
3194           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3195      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3196      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3197      &    *fac_shield(i)*fac_shield(j)
3198 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3199           aux=eel_loc_ij/sss*sssgrad*rmij
3200           ggg(1)=aux*xj
3201           ggg(2)=aux*yj
3202           ggg(3)=aux*zj
3203           do l=1,3
3204             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
3205      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3206      &    *fac_shield(i)*fac_shield(j)*sss
3207             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3208             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3209 cgrad            ghalf=0.5d0*ggg(l)
3210 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3211 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3212           enddo
3213 cgrad          do k=i+1,j2
3214 cgrad            do l=1,3
3215 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3216 cgrad            enddo
3217 cgrad          enddo
3218 C Remaining derivatives of eello
3219           do l=1,3
3220             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3221      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3222      &    *fac_shield(i)*fac_shield(j)
3223
3224             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3225      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3226      &    *fac_shield(i)*fac_shield(j)
3227
3228             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3229      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3230      &    *fac_shield(i)*fac_shield(j)
3231
3232             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3233      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3234      &    *fac_shield(i)*fac_shield(j)
3235
3236           enddo
3237           endif ! calc_grad
3238           ENDIF
3239
3240
3241 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3242 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3243 #ifdef FOURBODY
3244           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3245      &       .and. num_conti.le.maxconts) then
3246 c            write (iout,*) i,j," entered corr"
3247 C
3248 C Calculate the contact function. The ith column of the array JCONT will
3249 C contain the numbers of atoms that make contacts with the atom I (of numbers
3250 C greater than I). The arrays FACONT and GACONT will contain the values of
3251 C the contact function and its derivative.
3252 c           r0ij=1.02D0*rpp(iteli,itelj)
3253 c           r0ij=1.11D0*rpp(iteli,itelj)
3254             r0ij=2.20D0*rpp(iteli,itelj)
3255 c           r0ij=1.55D0*rpp(iteli,itelj)
3256             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3257             if (fcont.gt.0.0D0) then
3258               num_conti=num_conti+1
3259               if (num_conti.gt.maxconts) then
3260                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3261      &                         ' will skip next contacts for this conf.'
3262               else
3263                 jcont_hb(num_conti,i)=j
3264 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3265 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3266                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3267      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3268 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3269 C  terms.
3270                 d_cont(num_conti,i)=rij
3271 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3272 C     --- Electrostatic-interaction matrix ---
3273                 a_chuj(1,1,num_conti,i)=a22
3274                 a_chuj(1,2,num_conti,i)=a23
3275                 a_chuj(2,1,num_conti,i)=a32
3276                 a_chuj(2,2,num_conti,i)=a33
3277 C     --- Gradient of rij
3278                 if (calc_grad) then
3279                 do kkk=1,3
3280                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3281                 enddo
3282                 kkll=0
3283                 do k=1,2
3284                   do l=1,2
3285                     kkll=kkll+1
3286                     do m=1,3
3287                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3288                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3289                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3290                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3291                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3292                     enddo
3293                   enddo
3294                 enddo
3295                 endif ! calc_grad
3296                 ENDIF
3297                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3298 C Calculate contact energies
3299                 cosa4=4.0D0*cosa
3300                 wij=cosa-3.0D0*cosb*cosg
3301                 cosbg1=cosb+cosg
3302                 cosbg2=cosb-cosg
3303 c               fac3=dsqrt(-ael6i)/r0ij**3
3304                 fac3=dsqrt(-ael6i)*r3ij
3305 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3306                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3307                 if (ees0tmp.gt.0) then
3308                   ees0pij=dsqrt(ees0tmp)
3309                 else
3310                   ees0pij=0
3311                 endif
3312 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3313                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3314                 if (ees0tmp.gt.0) then
3315                   ees0mij=dsqrt(ees0tmp)
3316                 else
3317                   ees0mij=0
3318                 endif
3319 c               ees0mij=0.0D0
3320                 if (shield_mode.eq.0) then
3321                 fac_shield(i)=1.0d0
3322                 fac_shield(j)=1.0d0
3323                 else
3324                 ees0plist(num_conti,i)=j
3325 C                fac_shield(i)=0.4d0
3326 C                fac_shield(j)=0.6d0
3327                 endif
3328                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3329      &          *fac_shield(i)*fac_shield(j)
3330                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3331      &          *fac_shield(i)*fac_shield(j)
3332 C Diagnostics. Comment out or remove after debugging!
3333 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3334 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3335 c               ees0m(num_conti,i)=0.0D0
3336 C End diagnostics.
3337 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3338 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3339 C Angular derivatives of the contact function
3340
3341                 ees0pij1=fac3/ees0pij
3342                 ees0mij1=fac3/ees0mij
3343                 fac3p=-3.0D0*fac3*rrmij
3344                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3345                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3346 c               ees0mij1=0.0D0
3347                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3348                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3349                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3350                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3351                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3352                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3353                 ecosap=ecosa1+ecosa2
3354                 ecosbp=ecosb1+ecosb2
3355                 ecosgp=ecosg1+ecosg2
3356                 ecosam=ecosa1-ecosa2
3357                 ecosbm=ecosb1-ecosb2
3358                 ecosgm=ecosg1-ecosg2
3359 C Diagnostics
3360 c               ecosap=ecosa1
3361 c               ecosbp=ecosb1
3362 c               ecosgp=ecosg1
3363 c               ecosam=0.0D0
3364 c               ecosbm=0.0D0
3365 c               ecosgm=0.0D0
3366 C End diagnostics
3367                 facont_hb(num_conti,i)=fcont
3368
3369                 if (calc_grad) then
3370                 fprimcont=fprimcont/rij
3371 cd              facont_hb(num_conti,i)=1.0D0
3372 C Following line is for diagnostics.
3373 cd              fprimcont=0.0D0
3374                 do k=1,3
3375                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3376                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3377                 enddo
3378                 do k=1,3
3379                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3380                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3381                 enddo
3382                 gggp(1)=gggp(1)+ees0pijp*xj
3383      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
3384                 gggp(2)=gggp(2)+ees0pijp*yj
3385      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
3386                 gggp(3)=gggp(3)+ees0pijp*zj
3387      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
3388                 gggm(1)=gggm(1)+ees0mijp*xj
3389      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
3390                 gggm(2)=gggm(2)+ees0mijp*yj
3391      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
3392                 gggm(3)=gggm(3)+ees0mijp*zj
3393      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
3394 C Derivatives due to the contact function
3395                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3396                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3397                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3398                 do k=1,3
3399 c
3400 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3401 c          following the change of gradient-summation algorithm.
3402 c
3403 cgrad                  ghalfp=0.5D0*gggp(k)
3404 cgrad                  ghalfm=0.5D0*gggm(k)
3405                   gacontp_hb1(k,num_conti,i)=!ghalfp
3406      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3407      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3408      &          *fac_shield(i)*fac_shield(j)*sss
3409
3410                   gacontp_hb2(k,num_conti,i)=!ghalfp
3411      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3412      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3413      &          *fac_shield(i)*fac_shield(j)*sss
3414
3415                   gacontp_hb3(k,num_conti,i)=gggp(k)
3416      &          *fac_shield(i)*fac_shield(j)*sss
3417
3418                   gacontm_hb1(k,num_conti,i)=!ghalfm
3419      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3420      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3421      &          *fac_shield(i)*fac_shield(j)*sss
3422
3423                   gacontm_hb2(k,num_conti,i)=!ghalfm
3424      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3425      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3426      &          *fac_shield(i)*fac_shield(j)*sss
3427
3428                   gacontm_hb3(k,num_conti,i)=gggm(k)
3429      &          *fac_shield(i)*fac_shield(j)
3430 *sss
3431                 enddo
3432 C Diagnostics. Comment out or remove after debugging!
3433 cdiag           do k=1,3
3434 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3435 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3436 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3437 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3438 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3439 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3440 cdiag           enddo
3441
3442                  endif ! calc_grad
3443
3444               ENDIF ! wcorr
3445               endif  ! num_conti.le.maxconts
3446             endif  ! fcont.gt.0
3447           endif    ! j.gt.i+1
3448 #endif
3449           if (calc_grad) then
3450           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3451             do k=1,4
3452               do l=1,3
3453                 ghalf=0.5d0*agg(l,k)
3454                 aggi(l,k)=aggi(l,k)+ghalf
3455                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3456                 aggj(l,k)=aggj(l,k)+ghalf
3457               enddo
3458             enddo
3459             if (j.eq.nres-1 .and. i.lt.j-2) then
3460               do k=1,4
3461                 do l=1,3
3462                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3463                 enddo
3464               enddo
3465             endif
3466           endif
3467           endif ! calc_grad
3468 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3469       return
3470       end
3471 C-----------------------------------------------------------------------------
3472       subroutine eturn3(i,eello_turn3)
3473 C Third- and fourth-order contributions from turns
3474       implicit real*8 (a-h,o-z)
3475       include 'DIMENSIONS'
3476       include 'COMMON.IOUNITS'
3477       include 'COMMON.GEO'
3478       include 'COMMON.VAR'
3479       include 'COMMON.LOCAL'
3480       include 'COMMON.CHAIN'
3481       include 'COMMON.DERIV'
3482       include 'COMMON.INTERACT'
3483       include 'COMMON.CORRMAT'
3484       include 'COMMON.TORSION'
3485       include 'COMMON.VECTORS'
3486       include 'COMMON.FFIELD'
3487       include 'COMMON.CONTROL'
3488       include 'COMMON.SHIELD'
3489       dimension ggg(3)
3490       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3491      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3492      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3493      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3494      &  auxgmat2(2,2),auxgmatt2(2,2)
3495       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3496      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3497       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3498      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3499      &    num_conti,j1,j2
3500       j=i+2
3501 c      write (iout,*) "eturn3",i,j,j1,j2
3502       a_temp(1,1)=a22
3503       a_temp(1,2)=a23
3504       a_temp(2,1)=a32
3505       a_temp(2,2)=a33
3506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3507 C
3508 C               Third-order contributions
3509 C
3510 C                 (i+2)o----(i+3)
3511 C                      | |
3512 C                      | |
3513 C                 (i+1)o----i
3514 C
3515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3516 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3517         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3518 c auxalary matices for theta gradient
3519 c auxalary matrix for i+1 and constant i+2
3520         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3521 c auxalary matrix for i+2 and constant i+1
3522         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3523         call transpose2(auxmat(1,1),auxmat1(1,1))
3524         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3525         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3526         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3527         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3528         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3529         if (shield_mode.eq.0) then
3530         fac_shield(i)=1.0
3531         fac_shield(j)=1.0
3532 C        else
3533 C        fac_shield(i)=0.4
3534 C        fac_shield(j)=0.6
3535         endif
3536         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3537      &  *fac_shield(i)*fac_shield(j)
3538         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3539      &  *fac_shield(i)*fac_shield(j)
3540         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3541      &    eello_t3
3542         if (calc_grad) then
3543 C#ifdef NEWCORR
3544 C Derivatives in theta
3545         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3546      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3547      &   *fac_shield(i)*fac_shield(j)
3548         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3549      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3550      &   *fac_shield(i)*fac_shield(j)
3551 C#endif
3552
3553 C Derivatives in shield mode
3554           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3555      &  (shield_mode.gt.0)) then
3556 C          print *,i,j
3557
3558           do ilist=1,ishield_list(i)
3559            iresshield=shield_list(ilist,i)
3560            do k=1,3
3561            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3562 C     &      *2.0
3563            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3564      &              rlocshield
3565      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3566             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3567      &      +rlocshield
3568            enddo
3569           enddo
3570           do ilist=1,ishield_list(j)
3571            iresshield=shield_list(ilist,j)
3572            do k=1,3
3573            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3574 C     &     *2.0
3575            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3576      &              rlocshield
3577      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3578            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3579      &             +rlocshield
3580
3581            enddo
3582           enddo
3583
3584           do k=1,3
3585             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3586      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3587             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3588      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3589             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3590      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3591             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3592      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3593            enddo
3594            endif
3595
3596 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3597 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3598 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3599 cd     &    ' eello_turn3_num',4*eello_turn3_num
3600 C Derivatives in gamma(i)
3601         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3602         call transpose2(auxmat2(1,1),auxmat3(1,1))
3603         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3604         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3605      &   *fac_shield(i)*fac_shield(j)
3606 C Derivatives in gamma(i+1)
3607         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3608         call transpose2(auxmat2(1,1),auxmat3(1,1))
3609         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3610         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3611      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3612      &   *fac_shield(i)*fac_shield(j)
3613 C Cartesian derivatives
3614         do l=1,3
3615 c            ghalf1=0.5d0*agg(l,1)
3616 c            ghalf2=0.5d0*agg(l,2)
3617 c            ghalf3=0.5d0*agg(l,3)
3618 c            ghalf4=0.5d0*agg(l,4)
3619           a_temp(1,1)=aggi(l,1)!+ghalf1
3620           a_temp(1,2)=aggi(l,2)!+ghalf2
3621           a_temp(2,1)=aggi(l,3)!+ghalf3
3622           a_temp(2,2)=aggi(l,4)!+ghalf4
3623           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3624           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3625      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3626      &   *fac_shield(i)*fac_shield(j)
3627
3628           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3629           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3630           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3631           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3632           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3633           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3634      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3635      &   *fac_shield(i)*fac_shield(j)
3636           a_temp(1,1)=aggj(l,1)!+ghalf1
3637           a_temp(1,2)=aggj(l,2)!+ghalf2
3638           a_temp(2,1)=aggj(l,3)!+ghalf3
3639           a_temp(2,2)=aggj(l,4)!+ghalf4
3640           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3641           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3642      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3643      &   *fac_shield(i)*fac_shield(j)
3644           a_temp(1,1)=aggj1(l,1)
3645           a_temp(1,2)=aggj1(l,2)
3646           a_temp(2,1)=aggj1(l,3)
3647           a_temp(2,2)=aggj1(l,4)
3648           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3649           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3650      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3651      &   *fac_shield(i)*fac_shield(j)
3652         enddo
3653
3654         endif ! calc_grad
3655
3656       return
3657       end
3658 C-------------------------------------------------------------------------------
3659       subroutine eturn4(i,eello_turn4)
3660 C Third- and fourth-order contributions from turns
3661       implicit real*8 (a-h,o-z)
3662       include 'DIMENSIONS'
3663       include 'COMMON.IOUNITS'
3664       include 'COMMON.GEO'
3665       include 'COMMON.VAR'
3666       include 'COMMON.LOCAL'
3667       include 'COMMON.CHAIN'
3668       include 'COMMON.DERIV'
3669       include 'COMMON.INTERACT'
3670       include 'COMMON.CORRMAT'
3671       include 'COMMON.TORSION'
3672       include 'COMMON.VECTORS'
3673       include 'COMMON.FFIELD'
3674       include 'COMMON.CONTROL'
3675       include 'COMMON.SHIELD'
3676       dimension ggg(3)
3677       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3678      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3679      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3680      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3681      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3682      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3683      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3684       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3685      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3686       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3687      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3688      &    num_conti,j1,j2
3689       j=i+3
3690 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3691 C
3692 C               Fourth-order contributions
3693 C
3694 C                 (i+3)o----(i+4)
3695 C                     /  |
3696 C               (i+2)o   |
3697 C                     \  |
3698 C                 (i+1)o----i
3699 C
3700 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3701 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3702 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3703 c        write(iout,*)"WCHODZE W PROGRAM"
3704         a_temp(1,1)=a22
3705         a_temp(1,2)=a23
3706         a_temp(2,1)=a32
3707         a_temp(2,2)=a33
3708         iti1=itype2loc(itype(i+1))
3709         iti2=itype2loc(itype(i+2))
3710         iti3=itype2loc(itype(i+3))
3711 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3712         call transpose2(EUg(1,1,i+1),e1t(1,1))
3713         call transpose2(Eug(1,1,i+2),e2t(1,1))
3714         call transpose2(Eug(1,1,i+3),e3t(1,1))
3715 C Ematrix derivative in theta
3716         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3717         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3718         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3719         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3720 c       eta1 in derivative theta
3721         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3722         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3723 c       auxgvec is derivative of Ub2 so i+3 theta
3724         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3725 c       auxalary matrix of E i+1
3726         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3727 c        s1=0.0
3728 c        gs1=0.0
3729         s1=scalar2(b1(1,i+2),auxvec(1))
3730 c derivative of theta i+2 with constant i+3
3731         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3732 c derivative of theta i+2 with constant i+2
3733         gs32=scalar2(b1(1,i+2),auxgvec(1))
3734 c derivative of E matix in theta of i+1
3735         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3736
3737         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3738 c       ea31 in derivative theta
3739         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3740         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3741 c auxilary matrix auxgvec of Ub2 with constant E matirx
3742         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3743 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3744         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3745
3746 c        s2=0.0
3747 c        gs2=0.0
3748         s2=scalar2(b1(1,i+1),auxvec(1))
3749 c derivative of theta i+1 with constant i+3
3750         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3751 c derivative of theta i+2 with constant i+1
3752         gs21=scalar2(b1(1,i+1),auxgvec(1))
3753 c derivative of theta i+3 with constant i+1
3754         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3755 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3756 c     &  gtb1(1,i+1)
3757         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3758 c two derivatives over diffetent matrices
3759 c gtae3e2 is derivative over i+3
3760         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3761 c ae3gte2 is derivative over i+2
3762         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3763         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3764 c three possible derivative over theta E matices
3765 c i+1
3766         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3767 c i+2
3768         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3769 c i+3
3770         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3771         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3772
3773         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3774         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3775         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3776         if (shield_mode.eq.0) then
3777         fac_shield(i)=1.0
3778         fac_shield(j)=1.0
3779 C        else
3780 C        fac_shield(i)=0.6
3781 C        fac_shield(j)=0.4
3782         endif
3783         eello_turn4=eello_turn4-(s1+s2+s3)
3784      &  *fac_shield(i)*fac_shield(j)
3785         eello_t4=-(s1+s2+s3)
3786      &  *fac_shield(i)*fac_shield(j)
3787 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3788         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3789      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3790 C Now derivative over shield:
3791           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3792      &  (shield_mode.gt.0)) then
3793 C          print *,i,j
3794
3795           do ilist=1,ishield_list(i)
3796            iresshield=shield_list(ilist,i)
3797            do k=1,3
3798            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3799 C     &      *2.0
3800            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3801      &              rlocshield
3802      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3803             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3804      &      +rlocshield
3805            enddo
3806           enddo
3807           do ilist=1,ishield_list(j)
3808            iresshield=shield_list(ilist,j)
3809            do k=1,3
3810            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3811 C     &     *2.0
3812            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3813      &              rlocshield
3814      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3815            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3816      &             +rlocshield
3817
3818            enddo
3819           enddo
3820
3821           do k=1,3
3822             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3823      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3824             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3825      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3826             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3827      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3828             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3829      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3830            enddo
3831            endif
3832 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3833 cd     &    ' eello_turn4_num',8*eello_turn4_num
3834 #ifdef NEWCORR
3835         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3836      &                  -(gs13+gsE13+gsEE1)*wturn4
3837      &  *fac_shield(i)*fac_shield(j)
3838         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3839      &                    -(gs23+gs21+gsEE2)*wturn4
3840      &  *fac_shield(i)*fac_shield(j)
3841
3842         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3843      &                    -(gs32+gsE31+gsEE3)*wturn4
3844      &  *fac_shield(i)*fac_shield(j)
3845
3846 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3847 c     &   gs2
3848 #endif
3849         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3850      &      'eturn4',i,j,-(s1+s2+s3)
3851 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3852 c     &    ' eello_turn4_num',8*eello_turn4_num
3853 C Derivatives in gamma(i)
3854         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3855         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3856         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3857         s1=scalar2(b1(1,i+2),auxvec(1))
3858         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3859         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3860         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3861      &  *fac_shield(i)*fac_shield(j)
3862 C Derivatives in gamma(i+1)
3863         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3864         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3865         s2=scalar2(b1(1,i+1),auxvec(1))
3866         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3867         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3868         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3869         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3870      &  *fac_shield(i)*fac_shield(j)
3871 C Derivatives in gamma(i+2)
3872         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3873         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3874         s1=scalar2(b1(1,i+2),auxvec(1))
3875         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3876         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3877         s2=scalar2(b1(1,i+1),auxvec(1))
3878         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3879         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3880         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3881         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3882      &  *fac_shield(i)*fac_shield(j)
3883         if (calc_grad) then
3884 C Cartesian derivatives
3885 C Derivatives of this turn contributions in DC(i+2)
3886         if (j.lt.nres-1) then
3887           do l=1,3
3888             a_temp(1,1)=agg(l,1)
3889             a_temp(1,2)=agg(l,2)
3890             a_temp(2,1)=agg(l,3)
3891             a_temp(2,2)=agg(l,4)
3892             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3893             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3894             s1=scalar2(b1(1,i+2),auxvec(1))
3895             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3896             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3897             s2=scalar2(b1(1,i+1),auxvec(1))
3898             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3899             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3900             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3901             ggg(l)=-(s1+s2+s3)
3902             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3903      &  *fac_shield(i)*fac_shield(j)
3904           enddo
3905         endif
3906 C Remaining derivatives of this turn contribution
3907         do l=1,3
3908           a_temp(1,1)=aggi(l,1)
3909           a_temp(1,2)=aggi(l,2)
3910           a_temp(2,1)=aggi(l,3)
3911           a_temp(2,2)=aggi(l,4)
3912           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3913           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3914           s1=scalar2(b1(1,i+2),auxvec(1))
3915           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3916           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3917           s2=scalar2(b1(1,i+1),auxvec(1))
3918           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3919           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3920           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3921           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3922      &  *fac_shield(i)*fac_shield(j)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(l,4)
3927           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929           s1=scalar2(b1(1,i+2),auxvec(1))
3930           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932           s2=scalar2(b1(1,i+1),auxvec(1))
3933           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937      &  *fac_shield(i)*fac_shield(j)
3938           a_temp(1,1)=aggj(l,1)
3939           a_temp(1,2)=aggj(l,2)
3940           a_temp(2,1)=aggj(l,3)
3941           a_temp(2,2)=aggj(l,4)
3942           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3943           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3944           s1=scalar2(b1(1,i+2),auxvec(1))
3945           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3946           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3947           s2=scalar2(b1(1,i+1),auxvec(1))
3948           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3949           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3950           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3951           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3952      &  *fac_shield(i)*fac_shield(j)
3953           a_temp(1,1)=aggj1(l,1)
3954           a_temp(1,2)=aggj1(l,2)
3955           a_temp(2,1)=aggj1(l,3)
3956           a_temp(2,2)=aggj1(l,4)
3957           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3958           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3959           s1=scalar2(b1(1,i+2),auxvec(1))
3960           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3961           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3962           s2=scalar2(b1(1,i+1),auxvec(1))
3963           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3964           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3965           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3966 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3967           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3968      &  *fac_shield(i)*fac_shield(j)
3969         enddo
3970
3971         endif ! calc_grad
3972
3973       return
3974       end
3975 C-----------------------------------------------------------------------------
3976       subroutine vecpr(u,v,w)
3977       implicit real*8(a-h,o-z)
3978       dimension u(3),v(3),w(3)
3979       w(1)=u(2)*v(3)-u(3)*v(2)
3980       w(2)=-u(1)*v(3)+u(3)*v(1)
3981       w(3)=u(1)*v(2)-u(2)*v(1)
3982       return
3983       end
3984 C-----------------------------------------------------------------------------
3985       subroutine unormderiv(u,ugrad,unorm,ungrad)
3986 C This subroutine computes the derivatives of a normalized vector u, given
3987 C the derivatives computed without normalization conditions, ugrad. Returns
3988 C ungrad.
3989       implicit none
3990       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3991       double precision vec(3)
3992       double precision scalar
3993       integer i,j
3994 c      write (2,*) 'ugrad',ugrad
3995 c      write (2,*) 'u',u
3996       do i=1,3
3997         vec(i)=scalar(ugrad(1,i),u(1))
3998       enddo
3999 c      write (2,*) 'vec',vec
4000       do i=1,3
4001         do j=1,3
4002           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4003         enddo
4004       enddo
4005 c      write (2,*) 'ungrad',ungrad
4006       return
4007       end
4008 C-----------------------------------------------------------------------------
4009       subroutine escp(evdw2,evdw2_14)
4010 C
4011 C This subroutine calculates the excluded-volume interaction energy between
4012 C peptide-group centers and side chains and its gradient in virtual-bond and
4013 C side-chain vectors.
4014 C
4015       implicit real*8 (a-h,o-z)
4016       include 'DIMENSIONS'
4017       include 'COMMON.GEO'
4018       include 'COMMON.VAR'
4019       include 'COMMON.LOCAL'
4020       include 'COMMON.CHAIN'
4021       include 'COMMON.DERIV'
4022       include 'COMMON.INTERACT'
4023       include 'COMMON.FFIELD'
4024       include 'COMMON.IOUNITS'
4025       dimension ggg(3)
4026       evdw2=0.0D0
4027       evdw2_14=0.0d0
4028 cd    print '(a)','Enter ESCP'
4029 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4030 c     &  ' scal14',scal14
4031       do i=iatscp_s,iatscp_e
4032         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4033         iteli=itel(i)
4034 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4035 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4036         if (iteli.eq.0) goto 1225
4037         xi=0.5D0*(c(1,i)+c(1,i+1))
4038         yi=0.5D0*(c(2,i)+c(2,i+1))
4039         zi=0.5D0*(c(3,i)+c(3,i+1))
4040 C Returning the ith atom to box
4041           xi=mod(xi,boxxsize)
4042           if (xi.lt.0) xi=xi+boxxsize
4043           yi=mod(yi,boxysize)
4044           if (yi.lt.0) yi=yi+boxysize
4045           zi=mod(zi,boxzsize)
4046           if (zi.lt.0) zi=zi+boxzsize
4047         do iint=1,nscp_gr(i)
4048
4049         do j=iscpstart(i,iint),iscpend(i,iint)
4050           itypj=iabs(itype(j))
4051           if (itypj.eq.ntyp1) cycle
4052 C Uncomment following three lines for SC-p interactions
4053 c         xj=c(1,nres+j)-xi
4054 c         yj=c(2,nres+j)-yi
4055 c         zj=c(3,nres+j)-zi
4056 C Uncomment following three lines for Ca-p interactions
4057           xj=c(1,j)
4058           yj=c(2,j)
4059           zj=c(3,j)
4060 C returning the jth atom to box
4061           xj=mod(xj,boxxsize)
4062           if (xj.lt.0) xj=xj+boxxsize
4063           yj=mod(yj,boxysize)
4064           if (yj.lt.0) yj=yj+boxysize
4065           zj=mod(zj,boxzsize)
4066           if (zj.lt.0) zj=zj+boxzsize
4067       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4068       xj_safe=xj
4069       yj_safe=yj
4070       zj_safe=zj
4071       subchap=0
4072 C Finding the closest jth atom
4073       do xshift=-1,1
4074       do yshift=-1,1
4075       do zshift=-1,1
4076           xj=xj_safe+xshift*boxxsize
4077           yj=yj_safe+yshift*boxysize
4078           zj=zj_safe+zshift*boxzsize
4079           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4080           if(dist_temp.lt.dist_init) then
4081             dist_init=dist_temp
4082             xj_temp=xj
4083             yj_temp=yj
4084             zj_temp=zj
4085             subchap=1
4086           endif
4087        enddo
4088        enddo
4089        enddo
4090        if (subchap.eq.1) then
4091           xj=xj_temp-xi
4092           yj=yj_temp-yi
4093           zj=zj_temp-zi
4094        else
4095           xj=xj_safe-xi
4096           yj=yj_safe-yi
4097           zj=zj_safe-zi
4098        endif
4099           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4100 C sss is scaling function for smoothing the cutoff gradient otherwise
4101 C the gradient would not be continuouse
4102           sss=sscale(1.0d0/(dsqrt(rrij)))
4103           if (sss.le.0.0d0) cycle
4104           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4105           fac=rrij**expon2
4106           e1=fac*fac*aad(itypj,iteli)
4107           e2=fac*bad(itypj,iteli)
4108           if (iabs(j-i) .le. 2) then
4109             e1=scal14*e1
4110             e2=scal14*e2
4111             evdw2_14=evdw2_14+(e1+e2)*sss
4112           endif
4113           evdwij=e1+e2
4114 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4115 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4116 c     &       bad(itypj,iteli)
4117           evdw2=evdw2+evdwij*sss
4118           if (calc_grad) then
4119 C
4120 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4121 C
4122           fac=-(evdwij+e1)*rrij*sss
4123           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4124           ggg(1)=xj*fac
4125           ggg(2)=yj*fac
4126           ggg(3)=zj*fac
4127           if (j.lt.i) then
4128 cd          write (iout,*) 'j<i'
4129 C Uncomment following three lines for SC-p interactions
4130 c           do k=1,3
4131 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4132 c           enddo
4133           else
4134 cd          write (iout,*) 'j>i'
4135             do k=1,3
4136               ggg(k)=-ggg(k)
4137 C Uncomment following line for SC-p interactions
4138 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4139             enddo
4140           endif
4141           do k=1,3
4142             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4143           enddo
4144           kstart=min0(i+1,j)
4145           kend=max0(i-1,j-1)
4146 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4147 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4148           do k=kstart,kend
4149             do l=1,3
4150               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4151             enddo
4152           enddo
4153           endif ! calc_grad
4154         enddo
4155         enddo ! iint
4156  1225   continue
4157       enddo ! i
4158       do i=1,nct
4159         do j=1,3
4160           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4161           gradx_scp(j,i)=expon*gradx_scp(j,i)
4162         enddo
4163       enddo
4164 C******************************************************************************
4165 C
4166 C                              N O T E !!!
4167 C
4168 C To save time the factor EXPON has been extracted from ALL components
4169 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4170 C use!
4171 C
4172 C******************************************************************************
4173       return
4174       end
4175 C--------------------------------------------------------------------------
4176       subroutine edis(ehpb)
4177 C
4178 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4179 C
4180       implicit real*8 (a-h,o-z)
4181       include 'DIMENSIONS'
4182       include 'COMMON.SBRIDGE'
4183       include 'COMMON.CHAIN'
4184       include 'COMMON.DERIV'
4185       include 'COMMON.VAR'
4186       include 'COMMON.INTERACT'
4187       include 'COMMON.CONTROL'
4188       include 'COMMON.IOUNITS'
4189       dimension ggg(3),ggg_peak(3,1000)
4190       ehpb=0.0D0
4191       ggg=0.0d0
4192 c 8/21/18 AL: added explicit restraints on reference coords
4193 c      write (iout,*) "restr_on_coord",restr_on_coord
4194       if (restr_on_coord) then
4195
4196       do i=nnt,nct
4197         ecoor=0.0d0
4198         if (itype(i).eq.ntyp1) cycle
4199         do j=1,3
4200           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4201           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4202         enddo
4203         if (itype(i).ne.10) then
4204           do j=1,3
4205             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4206             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4207           enddo
4208         endif
4209         if (energy_dec) write (iout,*)
4210      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4211         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4212       enddo
4213
4214       endif
4215 C      write (iout,*) ,"link_end",link_end,constr_dist
4216 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4217 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4218 c     &  " constr_dist",constr_dist
4219       if (link_end.eq.0.and.link_end_peak.eq.0) return
4220       do i=link_start_peak,link_end_peak
4221         ehpb_peak=0.0d0
4222 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4223 c     &   ipeak(1,i),ipeak(2,i)
4224         do ip=ipeak(1,i),ipeak(2,i)
4225           ii=ihpb_peak(ip)
4226           jj=jhpb_peak(ip)
4227           dd=dist(ii,jj)
4228           iip=ip-ipeak(1,i)+1
4229 C iii and jjj point to the residues for which the distance is assigned.
4230 c          if (ii.gt.nres) then
4231 c            iii=ii-nres
4232 c            jjj=jj-nres
4233 c          else
4234 c            iii=ii
4235 c            jjj=jj
4236 c          endif
4237           if (ii.gt.nres) then
4238             iii=ii-nres
4239           else
4240             iii=ii
4241           endif
4242           if (jj.gt.nres) then
4243             jjj=jj-nres
4244           else
4245             jjj=jj
4246           endif
4247           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4248           aux=dexp(-scal_peak*aux)
4249           ehpb_peak=ehpb_peak+aux
4250           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4251      &      forcon_peak(ip))*aux/dd
4252           do j=1,3
4253             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4254           enddo
4255           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4256      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4257      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4258         enddo
4259 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4260         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4261         do ip=ipeak(1,i),ipeak(2,i)
4262           iip=ip-ipeak(1,i)+1
4263           do j=1,3
4264             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4265           enddo
4266           ii=ihpb_peak(ip)
4267           jj=jhpb_peak(ip)
4268 C iii and jjj point to the residues for which the distance is assigned.
4269 c          if (ii.gt.nres) then
4270 c            iii=ii-nres
4271 c            jjj=jj-nres
4272 c          else
4273 c            iii=ii
4274 c            jjj=jj
4275 c          endif
4276           if (ii.gt.nres) then
4277             iii=ii-nres
4278           else
4279             iii=ii
4280           endif
4281           if (jj.gt.nres) then
4282             jjj=jj-nres
4283           else
4284             jjj=jj
4285           endif
4286           if (iii.lt.ii) then
4287             do j=1,3
4288               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4289             enddo
4290           endif
4291           if (jjj.lt.jj) then
4292             do j=1,3
4293               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4294             enddo
4295           endif
4296           do k=1,3
4297             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4298             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4299           enddo
4300         enddo
4301       enddo
4302       do i=link_start,link_end
4303 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4304 C CA-CA distance used in regularization of structure.
4305         ii=ihpb(i)
4306         jj=jhpb(i)
4307 C iii and jjj point to the residues for which the distance is assigned.
4308 c        if (ii.gt.nres) then
4309 c          iii=ii-nres
4310 c          jjj=jj-nres
4311 c        else
4312 c          iii=ii
4313 c          jjj=jj
4314 c        endif
4315         if (ii.gt.nres) then
4316           iii=ii-nres
4317         else
4318           iii=ii
4319         endif
4320         if (jj.gt.nres) then
4321           jjj=jj-nres
4322         else
4323           jjj=jj
4324         endif
4325 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4326 c     &    dhpb(i),dhpb1(i),forcon(i)
4327 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4328 C    distance and angle dependent SS bond potential.
4329 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4330 C     & iabs(itype(jjj)).eq.1) then
4331 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4332 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4333         if (.not.dyn_ss .and. i.le.nss) then
4334 C 15/02/13 CC dynamic SSbond - additional check
4335           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4336      &        iabs(itype(jjj)).eq.1) then
4337            call ssbond_ene(iii,jjj,eij)
4338            ehpb=ehpb+2*eij
4339          endif
4340 cd          write (iout,*) "eij",eij
4341 cd   &   ' waga=',waga,' fac=',fac
4342 !        else if (ii.gt.nres .and. jj.gt.nres) then
4343         else
4344 C Calculate the distance between the two points and its difference from the
4345 C target distance.
4346           dd=dist(ii,jj)
4347           if (irestr_type(i).eq.11) then
4348             ehpb=ehpb+fordepth(i)!**4.0d0
4349      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4350             fac=fordepth(i)!**4.0d0
4351      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4352             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4353      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4354      &        ehpb,irestr_type(i)
4355           else if (irestr_type(i).eq.10) then
4356 c AL 6//19/2018 cross-link restraints
4357             xdis = 0.5d0*(dd/forcon(i))**2
4358             expdis = dexp(-xdis)
4359 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4360             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4361 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4362 c     &          " wboltzd",wboltzd
4363             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4364 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4365             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4366      &           *expdis/(aux*forcon(i)**2)
4367             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4368      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4369      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4370           else if (irestr_type(i).eq.2) then
4371 c Quartic restraints
4372             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4373             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4374      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4375      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4376             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4377           else
4378 c Quadratic restraints
4379             rdis=dd-dhpb(i)
4380 C Get the force constant corresponding to this distance.
4381             waga=forcon(i)
4382 C Calculate the contribution to energy.
4383             ehpb=ehpb+0.5d0*waga*rdis*rdis
4384             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4385      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4386      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4387 C
4388 C Evaluate gradient.
4389 C
4390             fac=waga*rdis/dd
4391           endif
4392 c Calculate Cartesian gradient
4393           do j=1,3
4394             ggg(j)=fac*(c(j,jj)-c(j,ii))
4395           enddo
4396 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4397 C If this is a SC-SC distance, we need to calculate the contributions to the
4398 C Cartesian gradient in the SC vectors (ghpbx).
4399           if (iii.lt.ii) then
4400             do j=1,3
4401               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4402             enddo
4403           endif
4404           if (jjj.lt.jj) then
4405             do j=1,3
4406               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4407             enddo
4408           endif
4409           do k=1,3
4410             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4411             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4412           enddo
4413         endif
4414       enddo
4415       return
4416       end
4417 C--------------------------------------------------------------------------
4418       subroutine ssbond_ene(i,j,eij)
4419 C
4420 C Calculate the distance and angle dependent SS-bond potential energy
4421 C using a free-energy function derived based on RHF/6-31G** ab initio
4422 C calculations of diethyl disulfide.
4423 C
4424 C A. Liwo and U. Kozlowska, 11/24/03
4425 C
4426       implicit real*8 (a-h,o-z)
4427       include 'DIMENSIONS'
4428       include 'COMMON.SBRIDGE'
4429       include 'COMMON.CHAIN'
4430       include 'COMMON.DERIV'
4431       include 'COMMON.LOCAL'
4432       include 'COMMON.INTERACT'
4433       include 'COMMON.VAR'
4434       include 'COMMON.IOUNITS'
4435       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4436       itypi=iabs(itype(i))
4437       xi=c(1,nres+i)
4438       yi=c(2,nres+i)
4439       zi=c(3,nres+i)
4440       dxi=dc_norm(1,nres+i)
4441       dyi=dc_norm(2,nres+i)
4442       dzi=dc_norm(3,nres+i)
4443       dsci_inv=dsc_inv(itypi)
4444       itypj=iabs(itype(j))
4445       dscj_inv=dsc_inv(itypj)
4446       xj=c(1,nres+j)-xi
4447       yj=c(2,nres+j)-yi
4448       zj=c(3,nres+j)-zi
4449       dxj=dc_norm(1,nres+j)
4450       dyj=dc_norm(2,nres+j)
4451       dzj=dc_norm(3,nres+j)
4452       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4453       rij=dsqrt(rrij)
4454       erij(1)=xj*rij
4455       erij(2)=yj*rij
4456       erij(3)=zj*rij
4457       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4458       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4459       om12=dxi*dxj+dyi*dyj+dzi*dzj
4460       do k=1,3
4461         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4462         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4463       enddo
4464       rij=1.0d0/rij
4465       deltad=rij-d0cm
4466       deltat1=1.0d0-om1
4467       deltat2=1.0d0+om2
4468       deltat12=om2-om1+2.0d0
4469       cosphi=om12-om1*om2
4470       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4471      &  +akct*deltad*deltat12
4472      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4473 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4474 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4475 c     &  " deltat12",deltat12," eij",eij
4476       ed=2*akcm*deltad+akct*deltat12
4477       pom1=akct*deltad
4478       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4479       eom1=-2*akth*deltat1-pom1-om2*pom2
4480       eom2= 2*akth*deltat2+pom1-om1*pom2
4481       eom12=pom2
4482       do k=1,3
4483         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4484       enddo
4485       do k=1,3
4486         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4487      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4488         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4489      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4490       enddo
4491 C
4492 C Calculate the components of the gradient in DC and X
4493 C
4494       do k=i,j-1
4495         do l=1,3
4496           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4497         enddo
4498       enddo
4499       return
4500       end
4501 C--------------------------------------------------------------------------
4502       subroutine ebond(estr)
4503 c
4504 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4505 c
4506       implicit real*8 (a-h,o-z)
4507       include 'DIMENSIONS'
4508       include 'COMMON.LOCAL'
4509       include 'COMMON.GEO'
4510       include 'COMMON.INTERACT'
4511       include 'COMMON.DERIV'
4512       include 'COMMON.VAR'
4513       include 'COMMON.CHAIN'
4514       include 'COMMON.IOUNITS'
4515       include 'COMMON.NAMES'
4516       include 'COMMON.FFIELD'
4517       include 'COMMON.CONTROL'
4518       double precision u(3),ud(3)
4519       estr=0.0d0
4520       estr1=0.0d0
4521 c      write (iout,*) "distchainmax",distchainmax
4522       do i=nnt+1,nct
4523         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4524 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4525 C          do j=1,3
4526 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4527 C     &      *dc(j,i-1)/vbld(i)
4528 C          enddo
4529 C          if (energy_dec) write(iout,*)
4530 C     &       "estr1",i,vbld(i),distchainmax,
4531 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4532 C        else
4533          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4534         diff = vbld(i)-vbldpDUM
4535 C         write(iout,*) i,diff
4536          else
4537           diff = vbld(i)-vbldp0
4538 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4539          endif
4540           estr=estr+diff*diff
4541           do j=1,3
4542             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4543           enddo
4544 C        endif
4545 C        write (iout,'(a7,i5,4f7.3)')
4546 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4547       enddo
4548       estr=0.5d0*AKP*estr+estr1
4549 c
4550 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4551 c
4552       do i=nnt,nct
4553         iti=iabs(itype(i))
4554         if (iti.ne.10 .and. iti.ne.ntyp1) then
4555           nbi=nbondterm(iti)
4556           if (nbi.eq.1) then
4557             diff=vbld(i+nres)-vbldsc0(1,iti)
4558 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4559 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4560             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4561             do j=1,3
4562               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4563             enddo
4564           else
4565             do j=1,nbi
4566               diff=vbld(i+nres)-vbldsc0(j,iti)
4567               ud(j)=aksc(j,iti)*diff
4568               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4569             enddo
4570             uprod=u(1)
4571             do j=2,nbi
4572               uprod=uprod*u(j)
4573             enddo
4574             usum=0.0d0
4575             usumsqder=0.0d0
4576             do j=1,nbi
4577               uprod1=1.0d0
4578               uprod2=1.0d0
4579               do k=1,nbi
4580                 if (k.ne.j) then
4581                   uprod1=uprod1*u(k)
4582                   uprod2=uprod2*u(k)*u(k)
4583                 endif
4584               enddo
4585               usum=usum+uprod1
4586               usumsqder=usumsqder+ud(j)*uprod2
4587             enddo
4588 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4589 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4590             estr=estr+uprod/usum
4591             do j=1,3
4592              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4593             enddo
4594           endif
4595         endif
4596       enddo
4597       return
4598       end
4599 #ifdef CRYST_THETA
4600 C--------------------------------------------------------------------------
4601       subroutine ebend(etheta,ethetacnstr)
4602 C
4603 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4604 C angles gamma and its derivatives in consecutive thetas and gammas.
4605 C
4606       implicit real*8 (a-h,o-z)
4607       include 'DIMENSIONS'
4608       include 'COMMON.LOCAL'
4609       include 'COMMON.GEO'
4610       include 'COMMON.INTERACT'
4611       include 'COMMON.DERIV'
4612       include 'COMMON.VAR'
4613       include 'COMMON.CHAIN'
4614       include 'COMMON.IOUNITS'
4615       include 'COMMON.NAMES'
4616       include 'COMMON.FFIELD'
4617       include 'COMMON.TORCNSTR'
4618       common /calcthet/ term1,term2,termm,diffak,ratak,
4619      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4620      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4621       double precision y(2),z(2)
4622       delta=0.02d0*pi
4623 c      time11=dexp(-2*time)
4624 c      time12=1.0d0
4625       etheta=0.0D0
4626 c      write (iout,*) "nres",nres
4627 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4628 c      write (iout,*) ithet_start,ithet_end
4629       do i=ithet_start,ithet_end
4630 C        if (itype(i-1).eq.ntyp1) cycle
4631         if (i.le.2) cycle
4632         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4633      &  .or.itype(i).eq.ntyp1) cycle
4634 C Zero the energy function and its derivative at 0 or pi.
4635         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4636         it=itype(i-1)
4637         ichir1=isign(1,itype(i-2))
4638         ichir2=isign(1,itype(i))
4639          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4640          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4641          if (itype(i-1).eq.10) then
4642           itype1=isign(10,itype(i-2))
4643           ichir11=isign(1,itype(i-2))
4644           ichir12=isign(1,itype(i-2))
4645           itype2=isign(10,itype(i))
4646           ichir21=isign(1,itype(i))
4647           ichir22=isign(1,itype(i))
4648          endif
4649          if (i.eq.3) then
4650           y(1)=0.0D0
4651           y(2)=0.0D0
4652           else
4653
4654         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4655 #ifdef OSF
4656           phii=phi(i)
4657 c          icrc=0
4658 c          call proc_proc(phii,icrc)
4659           if (icrc.eq.1) phii=150.0
4660 #else
4661           phii=phi(i)
4662 #endif
4663           y(1)=dcos(phii)
4664           y(2)=dsin(phii)
4665         else
4666           y(1)=0.0D0
4667           y(2)=0.0D0
4668         endif
4669         endif
4670         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4671 #ifdef OSF
4672           phii1=phi(i+1)
4673 c          icrc=0
4674 c          call proc_proc(phii1,icrc)
4675           if (icrc.eq.1) phii1=150.0
4676           phii1=pinorm(phii1)
4677           z(1)=cos(phii1)
4678 #else
4679           phii1=phi(i+1)
4680           z(1)=dcos(phii1)
4681 #endif
4682           z(2)=dsin(phii1)
4683         else
4684           z(1)=0.0D0
4685           z(2)=0.0D0
4686         endif
4687 C Calculate the "mean" value of theta from the part of the distribution
4688 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4689 C In following comments this theta will be referred to as t_c.
4690         thet_pred_mean=0.0d0
4691         do k=1,2
4692             athetk=athet(k,it,ichir1,ichir2)
4693             bthetk=bthet(k,it,ichir1,ichir2)
4694           if (it.eq.10) then
4695              athetk=athet(k,itype1,ichir11,ichir12)
4696              bthetk=bthet(k,itype2,ichir21,ichir22)
4697           endif
4698           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4699         enddo
4700 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4701         dthett=thet_pred_mean*ssd
4702         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4703 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4704 C Derivatives of the "mean" values in gamma1 and gamma2.
4705         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4706      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4707          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4708      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4709          if (it.eq.10) then
4710       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4711      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4712         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4713      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4714          endif
4715         if (theta(i).gt.pi-delta) then
4716           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4717      &         E_tc0)
4718           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4719           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4720           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4721      &        E_theta)
4722           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4723      &        E_tc)
4724         else if (theta(i).lt.delta) then
4725           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4726           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4727           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4728      &        E_theta)
4729           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4730           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4731      &        E_tc)
4732         else
4733           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4734      &        E_theta,E_tc)
4735         endif
4736         etheta=etheta+ethetai
4737 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4738 c     &      'ebend',i,ethetai,theta(i),itype(i)
4739 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4740 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4741         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4742         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4743         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4744 c 1215   continue
4745       enddo
4746       ethetacnstr=0.0d0
4747 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4748       do i=1,ntheta_constr
4749         itheta=itheta_constr(i)
4750         thetiii=theta(itheta)
4751         difi=pinorm(thetiii-theta_constr0(i))
4752         if (difi.gt.theta_drange(i)) then
4753           difi=difi-theta_drange(i)
4754           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4755           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4756      &    +for_thet_constr(i)*difi**3
4757         else if (difi.lt.-drange(i)) then
4758           difi=difi+drange(i)
4759           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4760           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4761      &    +for_thet_constr(i)*difi**3
4762         else
4763           difi=0.0
4764         endif
4765 C       if (energy_dec) then
4766 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4767 C     &    i,itheta,rad2deg*thetiii,
4768 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4769 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4770 C     &    gloc(itheta+nphi-2,icg)
4771 C        endif
4772       enddo
4773 C Ufff.... We've done all this!!!
4774       return
4775       end
4776 C---------------------------------------------------------------------------
4777       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4778      &     E_tc)
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.LOCAL'
4782       include 'COMMON.IOUNITS'
4783       common /calcthet/ term1,term2,termm,diffak,ratak,
4784      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4785      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4786 C Calculate the contributions to both Gaussian lobes.
4787 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4788 C The "polynomial part" of the "standard deviation" of this part of
4789 C the distribution.
4790         sig=polthet(3,it)
4791         do j=2,0,-1
4792           sig=sig*thet_pred_mean+polthet(j,it)
4793         enddo
4794 C Derivative of the "interior part" of the "standard deviation of the"
4795 C gamma-dependent Gaussian lobe in t_c.
4796         sigtc=3*polthet(3,it)
4797         do j=2,1,-1
4798           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4799         enddo
4800         sigtc=sig*sigtc
4801 C Set the parameters of both Gaussian lobes of the distribution.
4802 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4803         fac=sig*sig+sigc0(it)
4804         sigcsq=fac+fac
4805         sigc=1.0D0/sigcsq
4806 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4807         sigsqtc=-4.0D0*sigcsq*sigtc
4808 c       print *,i,sig,sigtc,sigsqtc
4809 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4810         sigtc=-sigtc/(fac*fac)
4811 C Following variable is sigma(t_c)**(-2)
4812         sigcsq=sigcsq*sigcsq
4813         sig0i=sig0(it)
4814         sig0inv=1.0D0/sig0i**2
4815         delthec=thetai-thet_pred_mean
4816         delthe0=thetai-theta0i
4817         term1=-0.5D0*sigcsq*delthec*delthec
4818         term2=-0.5D0*sig0inv*delthe0*delthe0
4819 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4820 C NaNs in taking the logarithm. We extract the largest exponent which is added
4821 C to the energy (this being the log of the distribution) at the end of energy
4822 C term evaluation for this virtual-bond angle.
4823         if (term1.gt.term2) then
4824           termm=term1
4825           term2=dexp(term2-termm)
4826           term1=1.0d0
4827         else
4828           termm=term2
4829           term1=dexp(term1-termm)
4830           term2=1.0d0
4831         endif
4832 C The ratio between the gamma-independent and gamma-dependent lobes of
4833 C the distribution is a Gaussian function of thet_pred_mean too.
4834         diffak=gthet(2,it)-thet_pred_mean
4835         ratak=diffak/gthet(3,it)**2
4836         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4837 C Let's differentiate it in thet_pred_mean NOW.
4838         aktc=ak*ratak
4839 C Now put together the distribution terms to make complete distribution.
4840         termexp=term1+ak*term2
4841         termpre=sigc+ak*sig0i
4842 C Contribution of the bending energy from this theta is just the -log of
4843 C the sum of the contributions from the two lobes and the pre-exponential
4844 C factor. Simple enough, isn't it?
4845         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4846 C NOW the derivatives!!!
4847 C 6/6/97 Take into account the deformation.
4848         E_theta=(delthec*sigcsq*term1
4849      &       +ak*delthe0*sig0inv*term2)/termexp
4850         E_tc=((sigtc+aktc*sig0i)/termpre
4851      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4852      &       aktc*term2)/termexp)
4853       return
4854       end
4855 c-----------------------------------------------------------------------------
4856       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4857       implicit real*8 (a-h,o-z)
4858       include 'DIMENSIONS'
4859       include 'COMMON.LOCAL'
4860       include 'COMMON.IOUNITS'
4861       common /calcthet/ term1,term2,termm,diffak,ratak,
4862      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4863      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4864       delthec=thetai-thet_pred_mean
4865       delthe0=thetai-theta0i
4866 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4867       t3 = thetai-thet_pred_mean
4868       t6 = t3**2
4869       t9 = term1
4870       t12 = t3*sigcsq
4871       t14 = t12+t6*sigsqtc
4872       t16 = 1.0d0
4873       t21 = thetai-theta0i
4874       t23 = t21**2
4875       t26 = term2
4876       t27 = t21*t26
4877       t32 = termexp
4878       t40 = t32**2
4879       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4880      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4881      & *(-t12*t9-ak*sig0inv*t27)
4882       return
4883       end
4884 #else
4885 C--------------------------------------------------------------------------
4886       subroutine ebend(etheta)
4887 C
4888 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4889 C angles gamma and its derivatives in consecutive thetas and gammas.
4890 C ab initio-derived potentials from
4891 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4892 C
4893       implicit real*8 (a-h,o-z)
4894       include 'DIMENSIONS'
4895       include 'COMMON.LOCAL'
4896       include 'COMMON.GEO'
4897       include 'COMMON.INTERACT'
4898       include 'COMMON.DERIV'
4899       include 'COMMON.VAR'
4900       include 'COMMON.CHAIN'
4901       include 'COMMON.IOUNITS'
4902       include 'COMMON.NAMES'
4903       include 'COMMON.FFIELD'
4904       include 'COMMON.CONTROL'
4905       include 'COMMON.TORCNSTR'
4906       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4907      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4908      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4909      & sinph1ph2(maxdouble,maxdouble)
4910       logical lprn /.false./, lprn1 /.false./
4911       etheta=0.0D0
4912 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4913       do i=ithet_start,ithet_end
4914 C         if (i.eq.2) cycle
4915 C        if (itype(i-1).eq.ntyp1) cycle
4916         if (i.le.2) cycle
4917         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4918      &  .or.itype(i).eq.ntyp1) cycle
4919         if (iabs(itype(i+1)).eq.20) iblock=2
4920         if (iabs(itype(i+1)).ne.20) iblock=1
4921         dethetai=0.0d0
4922         dephii=0.0d0
4923         dephii1=0.0d0
4924         theti2=0.5d0*theta(i)
4925         ityp2=ithetyp((itype(i-1)))
4926         do k=1,nntheterm
4927           coskt(k)=dcos(k*theti2)
4928           sinkt(k)=dsin(k*theti2)
4929         enddo
4930 cu        if (i.eq.3) then
4931 cu          phii=0.0d0
4932 cu          ityp1=nthetyp+1
4933 cu          do k=1,nsingle
4934 cu            cosph1(k)=0.0d0
4935 cu            sinph1(k)=0.0d0
4936 cu          enddo
4937 cu        else
4938         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4939 #ifdef OSF
4940           phii=phi(i)
4941           if (phii.ne.phii) phii=150.0
4942 #else
4943           phii=phi(i)
4944 #endif
4945           ityp1=ithetyp((itype(i-2)))
4946           do k=1,nsingle
4947             cosph1(k)=dcos(k*phii)
4948             sinph1(k)=dsin(k*phii)
4949           enddo
4950         else
4951           phii=0.0d0
4952 c          ityp1=nthetyp+1
4953           do k=1,nsingle
4954             ityp1=ithetyp((itype(i-2)))
4955             cosph1(k)=0.0d0
4956             sinph1(k)=0.0d0
4957           enddo
4958         endif
4959         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4960 #ifdef OSF
4961           phii1=phi(i+1)
4962           if (phii1.ne.phii1) phii1=150.0
4963           phii1=pinorm(phii1)
4964 #else
4965           phii1=phi(i+1)
4966 #endif
4967           ityp3=ithetyp((itype(i)))
4968           do k=1,nsingle
4969             cosph2(k)=dcos(k*phii1)
4970             sinph2(k)=dsin(k*phii1)
4971           enddo
4972         else
4973           phii1=0.0d0
4974 c          ityp3=nthetyp+1
4975           ityp3=ithetyp((itype(i)))
4976           do k=1,nsingle
4977             cosph2(k)=0.0d0
4978             sinph2(k)=0.0d0
4979           enddo
4980         endif
4981 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4982 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4983 c        call flush(iout)
4984         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4985         do k=1,ndouble
4986           do l=1,k-1
4987             ccl=cosph1(l)*cosph2(k-l)
4988             ssl=sinph1(l)*sinph2(k-l)
4989             scl=sinph1(l)*cosph2(k-l)
4990             csl=cosph1(l)*sinph2(k-l)
4991             cosph1ph2(l,k)=ccl-ssl
4992             cosph1ph2(k,l)=ccl+ssl
4993             sinph1ph2(l,k)=scl+csl
4994             sinph1ph2(k,l)=scl-csl
4995           enddo
4996         enddo
4997         if (lprn) then
4998         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4999      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5000         write (iout,*) "coskt and sinkt"
5001         do k=1,nntheterm
5002           write (iout,*) k,coskt(k),sinkt(k)
5003         enddo
5004         endif
5005         do k=1,ntheterm
5006           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5007           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5008      &      *coskt(k)
5009           if (lprn)
5010      &    write (iout,*) "k",k,"
5011      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5012      &     " ethetai",ethetai
5013         enddo
5014         if (lprn) then
5015         write (iout,*) "cosph and sinph"
5016         do k=1,nsingle
5017           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5018         enddo
5019         write (iout,*) "cosph1ph2 and sinph2ph2"
5020         do k=2,ndouble
5021           do l=1,k-1
5022             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5023      &         sinph1ph2(l,k),sinph1ph2(k,l)
5024           enddo
5025         enddo
5026         write(iout,*) "ethetai",ethetai
5027         endif
5028         do m=1,ntheterm2
5029           do k=1,nsingle
5030             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5031      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5032      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5033      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5034             ethetai=ethetai+sinkt(m)*aux
5035             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5036             dephii=dephii+k*sinkt(m)*(
5037      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5038      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5039             dephii1=dephii1+k*sinkt(m)*(
5040      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5041      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5042             if (lprn)
5043      &      write (iout,*) "m",m," k",k," bbthet",
5044      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5045      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5046      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5047      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5048           enddo
5049         enddo
5050         if (lprn)
5051      &  write(iout,*) "ethetai",ethetai
5052         do m=1,ntheterm3
5053           do k=2,ndouble
5054             do l=1,k-1
5055               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5056      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5057      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5058      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5059               ethetai=ethetai+sinkt(m)*aux
5060               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5061               dephii=dephii+l*sinkt(m)*(
5062      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5063      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5064      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5065      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5066               dephii1=dephii1+(k-l)*sinkt(m)*(
5067      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5068      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5069      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5070      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5071               if (lprn) then
5072               write (iout,*) "m",m," k",k," l",l," ffthet",
5073      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5074      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5075      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5076      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5077      &            " ethetai",ethetai
5078               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5079      &            cosph1ph2(k,l)*sinkt(m),
5080      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5081               endif
5082             enddo
5083           enddo
5084         enddo
5085 10      continue
5086         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5087      &   i,theta(i)*rad2deg,phii*rad2deg,
5088      &   phii1*rad2deg,ethetai
5089         etheta=etheta+ethetai
5090         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5091         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5092 c        gloc(nphi+i-2,icg)=wang*dethetai
5093         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5094       enddo
5095       return
5096       end
5097 #endif
5098 #ifdef CRYST_SC
5099 c-----------------------------------------------------------------------------
5100       subroutine esc(escloc)
5101 C Calculate the local energy of a side chain and its derivatives in the
5102 C corresponding virtual-bond valence angles THETA and the spherical angles
5103 C ALPHA and OMEGA.
5104       implicit real*8 (a-h,o-z)
5105       include 'DIMENSIONS'
5106       include 'COMMON.GEO'
5107       include 'COMMON.LOCAL'
5108       include 'COMMON.VAR'
5109       include 'COMMON.INTERACT'
5110       include 'COMMON.DERIV'
5111       include 'COMMON.CHAIN'
5112       include 'COMMON.IOUNITS'
5113       include 'COMMON.NAMES'
5114       include 'COMMON.FFIELD'
5115       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5116      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5117       common /sccalc/ time11,time12,time112,theti,it,nlobit
5118       delta=0.02d0*pi
5119       escloc=0.0D0
5120 C      write (iout,*) 'ESC'
5121       do i=loc_start,loc_end
5122         it=itype(i)
5123         if (it.eq.ntyp1) cycle
5124         if (it.eq.10) goto 1
5125         nlobit=nlob(iabs(it))
5126 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5127 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5128         theti=theta(i+1)-pipol
5129         x(1)=dtan(theti)
5130         x(2)=alph(i)
5131         x(3)=omeg(i)
5132 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5133
5134         if (x(2).gt.pi-delta) then
5135           xtemp(1)=x(1)
5136           xtemp(2)=pi-delta
5137           xtemp(3)=x(3)
5138           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5139           xtemp(2)=pi
5140           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5141           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5142      &        escloci,dersc(2))
5143           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5144      &        ddersc0(1),dersc(1))
5145           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5146      &        ddersc0(3),dersc(3))
5147           xtemp(2)=pi-delta
5148           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5149           xtemp(2)=pi
5150           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5151           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5152      &            dersc0(2),esclocbi,dersc02)
5153           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5154      &            dersc12,dersc01)
5155           call splinthet(x(2),0.5d0*delta,ss,ssd)
5156           dersc0(1)=dersc01
5157           dersc0(2)=dersc02
5158           dersc0(3)=0.0d0
5159           do k=1,3
5160             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5161           enddo
5162           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5163           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5164      &             esclocbi,ss,ssd
5165           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5166 c         escloci=esclocbi
5167 c         write (iout,*) escloci
5168         else if (x(2).lt.delta) then
5169           xtemp(1)=x(1)
5170           xtemp(2)=delta
5171           xtemp(3)=x(3)
5172           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5173           xtemp(2)=0.0d0
5174           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5175           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5176      &        escloci,dersc(2))
5177           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5178      &        ddersc0(1),dersc(1))
5179           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5180      &        ddersc0(3),dersc(3))
5181           xtemp(2)=delta
5182           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5183           xtemp(2)=0.0d0
5184           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5185           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5186      &            dersc0(2),esclocbi,dersc02)
5187           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5188      &            dersc12,dersc01)
5189           dersc0(1)=dersc01
5190           dersc0(2)=dersc02
5191           dersc0(3)=0.0d0
5192           call splinthet(x(2),0.5d0*delta,ss,ssd)
5193           do k=1,3
5194             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5195           enddo
5196           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5197 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5198 c     &             esclocbi,ss,ssd
5199           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5200 C         write (iout,*) 'i=',i, escloci
5201         else
5202           call enesc(x,escloci,dersc,ddummy,.false.)
5203         endif
5204
5205         escloc=escloc+escloci
5206 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5207             write (iout,'(a6,i5,0pf7.3)')
5208      &     'escloc',i,escloci
5209
5210         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5211      &   wscloc*dersc(1)
5212         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5213         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5214     1   continue
5215       enddo
5216       return
5217       end
5218 C---------------------------------------------------------------------------
5219       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5220       implicit real*8 (a-h,o-z)
5221       include 'DIMENSIONS'
5222       include 'COMMON.GEO'
5223       include 'COMMON.LOCAL'
5224       include 'COMMON.IOUNITS'
5225       common /sccalc/ time11,time12,time112,theti,it,nlobit
5226       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5227       double precision contr(maxlob,-1:1)
5228       logical mixed
5229 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5230         escloc_i=0.0D0
5231         do j=1,3
5232           dersc(j)=0.0D0
5233           if (mixed) ddersc(j)=0.0d0
5234         enddo
5235         x3=x(3)
5236
5237 C Because of periodicity of the dependence of the SC energy in omega we have
5238 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5239 C To avoid underflows, first compute & store the exponents.
5240
5241         do iii=-1,1
5242
5243           x(3)=x3+iii*dwapi
5244
5245           do j=1,nlobit
5246             do k=1,3
5247               z(k)=x(k)-censc(k,j,it)
5248             enddo
5249             do k=1,3
5250               Axk=0.0D0
5251               do l=1,3
5252                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5253               enddo
5254               Ax(k,j,iii)=Axk
5255             enddo
5256             expfac=0.0D0
5257             do k=1,3
5258               expfac=expfac+Ax(k,j,iii)*z(k)
5259             enddo
5260             contr(j,iii)=expfac
5261           enddo ! j
5262
5263         enddo ! iii
5264
5265         x(3)=x3
5266 C As in the case of ebend, we want to avoid underflows in exponentiation and
5267 C subsequent NaNs and INFs in energy calculation.
5268 C Find the largest exponent
5269         emin=contr(1,-1)
5270         do iii=-1,1
5271           do j=1,nlobit
5272             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5273           enddo
5274         enddo
5275         emin=0.5D0*emin
5276 cd      print *,'it=',it,' emin=',emin
5277
5278 C Compute the contribution to SC energy and derivatives
5279         do iii=-1,1
5280
5281           do j=1,nlobit
5282             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5283 cd          print *,'j=',j,' expfac=',expfac
5284             escloc_i=escloc_i+expfac
5285             do k=1,3
5286               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5287             enddo
5288             if (mixed) then
5289               do k=1,3,2
5290                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5291      &            +gaussc(k,2,j,it))*expfac
5292               enddo
5293             endif
5294           enddo
5295
5296         enddo ! iii
5297
5298         dersc(1)=dersc(1)/cos(theti)**2
5299         ddersc(1)=ddersc(1)/cos(theti)**2
5300         ddersc(3)=ddersc(3)
5301
5302         escloci=-(dlog(escloc_i)-emin)
5303         do j=1,3
5304           dersc(j)=dersc(j)/escloc_i
5305         enddo
5306         if (mixed) then
5307           do j=1,3,2
5308             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5309           enddo
5310         endif
5311       return
5312       end
5313 C------------------------------------------------------------------------------
5314       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5315       implicit real*8 (a-h,o-z)
5316       include 'DIMENSIONS'
5317       include 'COMMON.GEO'
5318       include 'COMMON.LOCAL'
5319       include 'COMMON.IOUNITS'
5320       common /sccalc/ time11,time12,time112,theti,it,nlobit
5321       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5322       double precision contr(maxlob)
5323       logical mixed
5324
5325       escloc_i=0.0D0
5326
5327       do j=1,3
5328         dersc(j)=0.0D0
5329       enddo
5330
5331       do j=1,nlobit
5332         do k=1,2
5333           z(k)=x(k)-censc(k,j,it)
5334         enddo
5335         z(3)=dwapi
5336         do k=1,3
5337           Axk=0.0D0
5338           do l=1,3
5339             Axk=Axk+gaussc(l,k,j,it)*z(l)
5340           enddo
5341           Ax(k,j)=Axk
5342         enddo
5343         expfac=0.0D0
5344         do k=1,3
5345           expfac=expfac+Ax(k,j)*z(k)
5346         enddo
5347         contr(j)=expfac
5348       enddo ! j
5349
5350 C As in the case of ebend, we want to avoid underflows in exponentiation and
5351 C subsequent NaNs and INFs in energy calculation.
5352 C Find the largest exponent
5353       emin=contr(1)
5354       do j=1,nlobit
5355         if (emin.gt.contr(j)) emin=contr(j)
5356       enddo
5357       emin=0.5D0*emin
5358
5359 C Compute the contribution to SC energy and derivatives
5360
5361       dersc12=0.0d0
5362       do j=1,nlobit
5363         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5364         escloc_i=escloc_i+expfac
5365         do k=1,2
5366           dersc(k)=dersc(k)+Ax(k,j)*expfac
5367         enddo
5368         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5369      &            +gaussc(1,2,j,it))*expfac
5370         dersc(3)=0.0d0
5371       enddo
5372
5373       dersc(1)=dersc(1)/cos(theti)**2
5374       dersc12=dersc12/cos(theti)**2
5375       escloci=-(dlog(escloc_i)-emin)
5376       do j=1,2
5377         dersc(j)=dersc(j)/escloc_i
5378       enddo
5379       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5380       return
5381       end
5382 #else
5383 c----------------------------------------------------------------------------------
5384       subroutine esc(escloc)
5385 C Calculate the local energy of a side chain and its derivatives in the
5386 C corresponding virtual-bond valence angles THETA and the spherical angles
5387 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5388 C added by Urszula Kozlowska. 07/11/2007
5389 C
5390       implicit real*8 (a-h,o-z)
5391       include 'DIMENSIONS'
5392       include 'COMMON.GEO'
5393       include 'COMMON.LOCAL'
5394       include 'COMMON.VAR'
5395       include 'COMMON.SCROT'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.DERIV'
5398       include 'COMMON.CHAIN'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.NAMES'
5401       include 'COMMON.FFIELD'
5402       include 'COMMON.CONTROL'
5403       include 'COMMON.VECTORS'
5404       double precision x_prime(3),y_prime(3),z_prime(3)
5405      &    , sumene,dsc_i,dp2_i,x(65),
5406      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5407      &    de_dxx,de_dyy,de_dzz,de_dt
5408       double precision s1_t,s1_6_t,s2_t,s2_6_t
5409       double precision
5410      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5411      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5412      & dt_dCi(3),dt_dCi1(3)
5413       common /sccalc/ time11,time12,time112,theti,it,nlobit
5414       delta=0.02d0*pi
5415       escloc=0.0D0
5416       do i=loc_start,loc_end
5417         if (itype(i).eq.ntyp1) cycle
5418         costtab(i+1) =dcos(theta(i+1))
5419         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5420         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5421         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5422         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5423         cosfac=dsqrt(cosfac2)
5424         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5425         sinfac=dsqrt(sinfac2)
5426         it=iabs(itype(i))
5427         if (it.eq.10) goto 1
5428 c
5429 C  Compute the axes of tghe local cartesian coordinates system; store in
5430 c   x_prime, y_prime and z_prime
5431 c
5432         do j=1,3
5433           x_prime(j) = 0.00
5434           y_prime(j) = 0.00
5435           z_prime(j) = 0.00
5436         enddo
5437 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5438 C     &   dc_norm(3,i+nres)
5439         do j = 1,3
5440           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5441           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5442         enddo
5443         do j = 1,3
5444           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5445         enddo
5446 c       write (2,*) "i",i
5447 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5448 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5449 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5450 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5451 c      & " xy",scalar(x_prime(1),y_prime(1)),
5452 c      & " xz",scalar(x_prime(1),z_prime(1)),
5453 c      & " yy",scalar(y_prime(1),y_prime(1)),
5454 c      & " yz",scalar(y_prime(1),z_prime(1)),
5455 c      & " zz",scalar(z_prime(1),z_prime(1))
5456 c
5457 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5458 C to local coordinate system. Store in xx, yy, zz.
5459 c
5460         xx=0.0d0
5461         yy=0.0d0
5462         zz=0.0d0
5463         do j = 1,3
5464           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5465           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5466           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5467         enddo
5468
5469         xxtab(i)=xx
5470         yytab(i)=yy
5471         zztab(i)=zz
5472 C
5473 C Compute the energy of the ith side cbain
5474 C
5475 c        write (2,*) "xx",xx," yy",yy," zz",zz
5476         it=iabs(itype(i))
5477         do j = 1,65
5478           x(j) = sc_parmin(j,it)
5479         enddo
5480 #ifdef CHECK_COORD
5481 Cc diagnostics - remove later
5482         xx1 = dcos(alph(2))
5483         yy1 = dsin(alph(2))*dcos(omeg(2))
5484         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5485         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5486      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5487      &    xx1,yy1,zz1
5488 C,"  --- ", xx_w,yy_w,zz_w
5489 c end diagnostics
5490 #endif
5491         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5492      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5493      &   + x(10)*yy*zz
5494         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5495      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5496      & + x(20)*yy*zz
5497         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5498      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5499      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5500      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5501      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5502      &  +x(40)*xx*yy*zz
5503         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5504      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5505      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5506      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5507      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5508      &  +x(60)*xx*yy*zz
5509         dsc_i   = 0.743d0+x(61)
5510         dp2_i   = 1.9d0+x(62)
5511         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5512      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5513         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5514      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5515         s1=(1+x(63))/(0.1d0 + dscp1)
5516         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5517         s2=(1+x(65))/(0.1d0 + dscp2)
5518         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5519         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5520      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5521 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5522 c     &   sumene4,
5523 c     &   dscp1,dscp2,sumene
5524 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5525         escloc = escloc + sumene
5526 c        write (2,*) "escloc",escloc
5527 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5528 c     &  zz,xx,yy
5529         if (.not. calc_grad) goto 1
5530 #ifdef DEBUG
5531 C
5532 C This section to check the numerical derivatives of the energy of ith side
5533 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5534 C #define DEBUG in the code to turn it on.
5535 C
5536         write (2,*) "sumene               =",sumene
5537         aincr=1.0d-7
5538         xxsave=xx
5539         xx=xx+aincr
5540         write (2,*) xx,yy,zz
5541         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5542         de_dxx_num=(sumenep-sumene)/aincr
5543         xx=xxsave
5544         write (2,*) "xx+ sumene from enesc=",sumenep
5545         yysave=yy
5546         yy=yy+aincr
5547         write (2,*) xx,yy,zz
5548         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5549         de_dyy_num=(sumenep-sumene)/aincr
5550         yy=yysave
5551         write (2,*) "yy+ sumene from enesc=",sumenep
5552         zzsave=zz
5553         zz=zz+aincr
5554         write (2,*) xx,yy,zz
5555         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5556         de_dzz_num=(sumenep-sumene)/aincr
5557         zz=zzsave
5558         write (2,*) "zz+ sumene from enesc=",sumenep
5559         costsave=cost2tab(i+1)
5560         sintsave=sint2tab(i+1)
5561         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5562         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5563         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5564         de_dt_num=(sumenep-sumene)/aincr
5565         write (2,*) " t+ sumene from enesc=",sumenep
5566         cost2tab(i+1)=costsave
5567         sint2tab(i+1)=sintsave
5568 C End of diagnostics section.
5569 #endif
5570 C
5571 C Compute the gradient of esc
5572 C
5573         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5574         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5575         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5576         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5577         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5578         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5579         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5580         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5581         pom1=(sumene3*sint2tab(i+1)+sumene1)
5582      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5583         pom2=(sumene4*cost2tab(i+1)+sumene2)
5584      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5585         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5586         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5587      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5588      &  +x(40)*yy*zz
5589         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5590         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5591      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5592      &  +x(60)*yy*zz
5593         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5594      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5595      &        +(pom1+pom2)*pom_dx
5596 #ifdef DEBUG
5597         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5598 #endif
5599 C
5600         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5601         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5602      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5603      &  +x(40)*xx*zz
5604         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5605         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5606      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5607      &  +x(59)*zz**2 +x(60)*xx*zz
5608         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5609      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5610      &        +(pom1-pom2)*pom_dy
5611 #ifdef DEBUG
5612         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5613 #endif
5614 C
5615         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5616      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5617      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5618      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5619      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5620      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5621      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5622      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5623 #ifdef DEBUG
5624         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5625 #endif
5626 C
5627         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5628      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5629      &  +pom1*pom_dt1+pom2*pom_dt2
5630 #ifdef DEBUG
5631         write(2,*), "de_dt = ", de_dt,de_dt_num
5632 #endif
5633 c
5634 C
5635        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5636        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5637        cosfac2xx=cosfac2*xx
5638        sinfac2yy=sinfac2*yy
5639        do k = 1,3
5640          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5641      &      vbld_inv(i+1)
5642          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5643      &      vbld_inv(i)
5644          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5645          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5646 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5647 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5648 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5649 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5650          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5651          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5652          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5653          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5654          dZZ_Ci1(k)=0.0d0
5655          dZZ_Ci(k)=0.0d0
5656          do j=1,3
5657            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5658      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5659            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5660      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5661          enddo
5662
5663          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5664          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5665          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5666 c
5667          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5668          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5669        enddo
5670
5671        do k=1,3
5672          dXX_Ctab(k,i)=dXX_Ci(k)
5673          dXX_C1tab(k,i)=dXX_Ci1(k)
5674          dYY_Ctab(k,i)=dYY_Ci(k)
5675          dYY_C1tab(k,i)=dYY_Ci1(k)
5676          dZZ_Ctab(k,i)=dZZ_Ci(k)
5677          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5678          dXX_XYZtab(k,i)=dXX_XYZ(k)
5679          dYY_XYZtab(k,i)=dYY_XYZ(k)
5680          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5681        enddo
5682
5683        do k = 1,3
5684 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5685 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5686 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5687 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5688 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5689 c     &    dt_dci(k)
5690 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5691 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5692          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5693      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5694          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5695      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5696          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5697      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5698        enddo
5699 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5700 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5701
5702 C to check gradient call subroutine check_grad
5703
5704     1 continue
5705       enddo
5706       return
5707       end
5708 #endif
5709 c------------------------------------------------------------------------------
5710       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5711 C
5712 C This procedure calculates two-body contact function g(rij) and its derivative:
5713 C
5714 C           eps0ij                                     !       x < -1
5715 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5716 C            0                                         !       x > 1
5717 C
5718 C where x=(rij-r0ij)/delta
5719 C
5720 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5721 C
5722       implicit none
5723       double precision rij,r0ij,eps0ij,fcont,fprimcont
5724       double precision x,x2,x4,delta
5725 c     delta=0.02D0*r0ij
5726 c      delta=0.2D0*r0ij
5727       x=(rij-r0ij)/delta
5728       if (x.lt.-1.0D0) then
5729         fcont=eps0ij
5730         fprimcont=0.0D0
5731       else if (x.le.1.0D0) then
5732         x2=x*x
5733         x4=x2*x2
5734         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5735         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5736       else
5737         fcont=0.0D0
5738         fprimcont=0.0D0
5739       endif
5740       return
5741       end
5742 c------------------------------------------------------------------------------
5743       subroutine splinthet(theti,delta,ss,ssder)
5744       implicit real*8 (a-h,o-z)
5745       include 'DIMENSIONS'
5746       include 'COMMON.VAR'
5747       include 'COMMON.GEO'
5748       thetup=pi-delta
5749       thetlow=delta
5750       if (theti.gt.pipol) then
5751         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5752       else
5753         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5754         ssder=-ssder
5755       endif
5756       return
5757       end
5758 c------------------------------------------------------------------------------
5759       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5760       implicit none
5761       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5762       double precision ksi,ksi2,ksi3,a1,a2,a3
5763       a1=fprim0*delta/(f1-f0)
5764       a2=3.0d0-2.0d0*a1
5765       a3=a1-2.0d0
5766       ksi=(x-x0)/delta
5767       ksi2=ksi*ksi
5768       ksi3=ksi2*ksi
5769       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5770       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5771       return
5772       end
5773 c------------------------------------------------------------------------------
5774       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5775       implicit none
5776       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5777       double precision ksi,ksi2,ksi3,a1,a2,a3
5778       ksi=(x-x0)/delta
5779       ksi2=ksi*ksi
5780       ksi3=ksi2*ksi
5781       a1=fprim0x*delta
5782       a2=3*(f1x-f0x)-2*fprim0x*delta
5783       a3=fprim0x*delta-2*(f1x-f0x)
5784       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5785       return
5786       end
5787 C-----------------------------------------------------------------------------
5788 #ifdef CRYST_TOR
5789 C-----------------------------------------------------------------------------
5790       subroutine etor(etors,fact)
5791       implicit real*8 (a-h,o-z)
5792       include 'DIMENSIONS'
5793       include 'COMMON.VAR'
5794       include 'COMMON.GEO'
5795       include 'COMMON.LOCAL'
5796       include 'COMMON.TORSION'
5797       include 'COMMON.INTERACT'
5798       include 'COMMON.DERIV'
5799       include 'COMMON.CHAIN'
5800       include 'COMMON.NAMES'
5801       include 'COMMON.IOUNITS'
5802       include 'COMMON.FFIELD'
5803       include 'COMMON.TORCNSTR'
5804       logical lprn
5805 C Set lprn=.true. for debugging
5806       lprn=.false.
5807 c      lprn=.true.
5808       etors=0.0D0
5809       do i=iphi_start,iphi_end
5810         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5811      &      .or. itype(i).eq.ntyp1) cycle
5812         itori=itortyp(itype(i-2))
5813         itori1=itortyp(itype(i-1))
5814         phii=phi(i)
5815         gloci=0.0D0
5816 C Proline-Proline pair is a special case...
5817         if (itori.eq.3 .and. itori1.eq.3) then
5818           if (phii.gt.-dwapi3) then
5819             cosphi=dcos(3*phii)
5820             fac=1.0D0/(1.0D0-cosphi)
5821             etorsi=v1(1,3,3)*fac
5822             etorsi=etorsi+etorsi
5823             etors=etors+etorsi-v1(1,3,3)
5824             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5825           endif
5826           do j=1,3
5827             v1ij=v1(j+1,itori,itori1)
5828             v2ij=v2(j+1,itori,itori1)
5829             cosphi=dcos(j*phii)
5830             sinphi=dsin(j*phii)
5831             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5832             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5833           enddo
5834         else
5835           do j=1,nterm_old
5836             v1ij=v1(j,itori,itori1)
5837             v2ij=v2(j,itori,itori1)
5838             cosphi=dcos(j*phii)
5839             sinphi=dsin(j*phii)
5840             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5841             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5842           enddo
5843         endif
5844         if (lprn)
5845      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5846      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5847      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5848         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5849 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5850       enddo
5851       return
5852       end
5853 c------------------------------------------------------------------------------
5854 #else
5855       subroutine etor(etors,fact)
5856       implicit real*8 (a-h,o-z)
5857       include 'DIMENSIONS'
5858       include 'COMMON.VAR'
5859       include 'COMMON.GEO'
5860       include 'COMMON.LOCAL'
5861       include 'COMMON.TORSION'
5862       include 'COMMON.INTERACT'
5863       include 'COMMON.DERIV'
5864       include 'COMMON.CHAIN'
5865       include 'COMMON.NAMES'
5866       include 'COMMON.IOUNITS'
5867       include 'COMMON.FFIELD'
5868       include 'COMMON.TORCNSTR'
5869       logical lprn
5870 C Set lprn=.true. for debugging
5871       lprn=.false.
5872 c      lprn=.true.
5873       etors=0.0D0
5874       do i=iphi_start,iphi_end
5875         if (i.le.2) cycle
5876         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5877      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5878 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5879 C     &       .or. itype(i).eq.ntyp1) cycle
5880         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5881          if (iabs(itype(i)).eq.20) then
5882          iblock=2
5883          else
5884          iblock=1
5885          endif
5886         itori=itortyp(itype(i-2))
5887         itori1=itortyp(itype(i-1))
5888         phii=phi(i)
5889         gloci=0.0D0
5890 C Regular cosine and sine terms
5891         do j=1,nterm(itori,itori1,iblock)
5892           v1ij=v1(j,itori,itori1,iblock)
5893           v2ij=v2(j,itori,itori1,iblock)
5894           cosphi=dcos(j*phii)
5895           sinphi=dsin(j*phii)
5896           etors=etors+v1ij*cosphi+v2ij*sinphi
5897           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5898         enddo
5899 C Lorentz terms
5900 C                         v1
5901 C  E = SUM ----------------------------------- - v1
5902 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5903 C
5904         cosphi=dcos(0.5d0*phii)
5905         sinphi=dsin(0.5d0*phii)
5906         do j=1,nlor(itori,itori1,iblock)
5907           vl1ij=vlor1(j,itori,itori1)
5908           vl2ij=vlor2(j,itori,itori1)
5909           vl3ij=vlor3(j,itori,itori1)
5910           pom=vl2ij*cosphi+vl3ij*sinphi
5911           pom1=1.0d0/(pom*pom+1.0d0)
5912           etors=etors+vl1ij*pom1
5913 c          if (energy_dec) etors_ii=etors_ii+
5914 c     &                vl1ij*pom1
5915           pom=-pom*pom1*pom1
5916           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5917         enddo
5918 C Subtract the constant term
5919         etors=etors-v0(itori,itori1,iblock)
5920         if (lprn)
5921      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5922      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5923      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5924         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5925 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5926  1215   continue
5927       enddo
5928       return
5929       end
5930 c----------------------------------------------------------------------------
5931       subroutine etor_d(etors_d,fact2)
5932 C 6/23/01 Compute double torsional energy
5933       implicit real*8 (a-h,o-z)
5934       include 'DIMENSIONS'
5935       include 'COMMON.VAR'
5936       include 'COMMON.GEO'
5937       include 'COMMON.LOCAL'
5938       include 'COMMON.TORSION'
5939       include 'COMMON.INTERACT'
5940       include 'COMMON.DERIV'
5941       include 'COMMON.CHAIN'
5942       include 'COMMON.NAMES'
5943       include 'COMMON.IOUNITS'
5944       include 'COMMON.FFIELD'
5945       include 'COMMON.TORCNSTR'
5946       logical lprn
5947 C Set lprn=.true. for debugging
5948       lprn=.false.
5949 c     lprn=.true.
5950       etors_d=0.0D0
5951       do i=iphi_start,iphi_end-1
5952         if (i.le.3) cycle
5953 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5954 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5955          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5956      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5957      &  (itype(i+1).eq.ntyp1)) cycle
5958         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5959      &     goto 1215
5960         itori=itortyp(itype(i-2))
5961         itori1=itortyp(itype(i-1))
5962         itori2=itortyp(itype(i))
5963         phii=phi(i)
5964         phii1=phi(i+1)
5965         gloci1=0.0D0
5966         gloci2=0.0D0
5967         iblock=1
5968         if (iabs(itype(i+1)).eq.20) iblock=2
5969 C Regular cosine and sine terms
5970         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5971           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5972           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5973           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5974           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5975           cosphi1=dcos(j*phii)
5976           sinphi1=dsin(j*phii)
5977           cosphi2=dcos(j*phii1)
5978           sinphi2=dsin(j*phii1)
5979           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5980      &     v2cij*cosphi2+v2sij*sinphi2
5981           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5982           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5983         enddo
5984         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5985           do l=1,k-1
5986             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5987             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5988             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5989             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5990             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5991             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5992             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5993             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5994             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5995      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5996             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5997      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5998             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5999      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6000           enddo
6001         enddo
6002         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6003         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6004  1215   continue
6005       enddo
6006       return
6007       end
6008 #endif
6009 c---------------------------------------------------------------------------
6010 C The rigorous attempt to derive energy function
6011       subroutine etor_kcc(etors,fact)
6012       implicit real*8 (a-h,o-z)
6013       include 'DIMENSIONS'
6014       include 'COMMON.VAR'
6015       include 'COMMON.GEO'
6016       include 'COMMON.LOCAL'
6017       include 'COMMON.TORSION'
6018       include 'COMMON.INTERACT'
6019       include 'COMMON.DERIV'
6020       include 'COMMON.CHAIN'
6021       include 'COMMON.NAMES'
6022       include 'COMMON.IOUNITS'
6023       include 'COMMON.FFIELD'
6024       include 'COMMON.TORCNSTR'
6025       include 'COMMON.CONTROL'
6026       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
6027       logical lprn
6028 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
6029 C Set lprn=.true. for debugging
6030       lprn=energy_dec
6031 c     lprn=.true.
6032 C      print *,"wchodze kcc"
6033       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
6034       etors=0.0D0
6035       do i=iphi_start,iphi_end
6036 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6037 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6038 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6039 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6040         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6041      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6042         itori=itortyp(itype(i-2))
6043         itori1=itortyp(itype(i-1))
6044         phii=phi(i)
6045         glocig=0.0D0
6046         glocit1=0.0d0
6047         glocit2=0.0d0
6048 C to avoid multiple devision by 2
6049 c        theti22=0.5d0*theta(i)
6050 C theta 12 is the theta_1 /2
6051 C theta 22 is theta_2 /2
6052 c        theti12=0.5d0*theta(i-1)
6053 C and appropriate sinus function
6054         sinthet1=dsin(theta(i-1))
6055         sinthet2=dsin(theta(i))
6056         costhet1=dcos(theta(i-1))
6057         costhet2=dcos(theta(i))
6058 C to speed up lets store its mutliplication
6059         sint1t2=sinthet2*sinthet1
6060         sint1t2n=1.0d0
6061 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
6062 C +d_n*sin(n*gamma)) *
6063 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
6064 C we have two sum 1) Non-Chebyshev which is with n and gamma
6065         nval=nterm_kcc_Tb(itori,itori1)
6066         c1(0)=0.0d0
6067         c2(0)=0.0d0
6068         c1(1)=1.0d0
6069         c2(1)=1.0d0
6070         do j=2,nval
6071           c1(j)=c1(j-1)*costhet1
6072           c2(j)=c2(j-1)*costhet2
6073         enddo
6074         etori=0.0d0
6075         do j=1,nterm_kcc(itori,itori1)
6076           cosphi=dcos(j*phii)
6077           sinphi=dsin(j*phii)
6078           sint1t2n1=sint1t2n
6079           sint1t2n=sint1t2n*sint1t2
6080           sumvalc=0.0d0
6081           gradvalct1=0.0d0
6082           gradvalct2=0.0d0
6083           do k=1,nval
6084             do l=1,nval
6085               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6086               gradvalct1=gradvalct1+
6087      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6088               gradvalct2=gradvalct2+
6089      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6090             enddo
6091           enddo
6092           gradvalct1=-gradvalct1*sinthet1
6093           gradvalct2=-gradvalct2*sinthet2
6094           sumvals=0.0d0
6095           gradvalst1=0.0d0
6096           gradvalst2=0.0d0
6097           do k=1,nval
6098             do l=1,nval
6099               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
6100               gradvalst1=gradvalst1+
6101      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
6102               gradvalst2=gradvalst2+
6103      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
6104             enddo
6105           enddo
6106           gradvalst1=-gradvalst1*sinthet1
6107           gradvalst2=-gradvalst2*sinthet2
6108           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
6109 C glocig is the gradient local i site in gamma
6110           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
6111 C now gradient over theta_1
6112           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
6113      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
6114           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
6115      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
6116         enddo ! j
6117         etors=etors+etori
6118 C derivative over gamma
6119         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6120 C derivative over theta1
6121         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6122 C now derivative over theta2
6123         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6124         if (lprn)
6125      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6126      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6127       enddo
6128       return
6129       end
6130 c---------------------------------------------------------------------------------------------
6131       subroutine etor_constr(edihcnstr)
6132       implicit real*8 (a-h,o-z)
6133       include 'DIMENSIONS'
6134       include 'COMMON.VAR'
6135       include 'COMMON.GEO'
6136       include 'COMMON.LOCAL'
6137       include 'COMMON.TORSION'
6138       include 'COMMON.INTERACT'
6139       include 'COMMON.DERIV'
6140       include 'COMMON.CHAIN'
6141       include 'COMMON.NAMES'
6142       include 'COMMON.IOUNITS'
6143       include 'COMMON.FFIELD'
6144       include 'COMMON.TORCNSTR'
6145       include 'COMMON.CONTROL'
6146 ! 6/20/98 - dihedral angle constraints
6147       edihcnstr=0.0d0
6148 c      do i=1,ndih_constr
6149 c      write (iout,*) "idihconstr_start",idihconstr_start,
6150 c     &  " idihconstr_end",idihconstr_end
6151       if (raw_psipred) then
6152         do i=idihconstr_start,idihconstr_end
6153           itori=idih_constr(i)
6154           phii=phi(itori)
6155           gaudih_i=vpsipred(1,i)
6156           gauder_i=0.0d0
6157           do j=1,2
6158             s = sdihed(j,i)
6159             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6160             dexpcos_i=dexp(-cos_i*cos_i)
6161             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6162             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6163      &            *cos_i*dexpcos_i/s**2
6164           enddo
6165           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6166           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6167           if (energy_dec)
6168      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6169      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6170      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6171      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6172      &     -wdihc*dlog(gaudih_i)
6173         enddo
6174       else
6175         do i=idihconstr_start,idihconstr_end
6176           itori=idih_constr(i)
6177           phii=phi(itori)
6178           difi=pinorm(phii-phi0(i))
6179           if (difi.gt.drange(i)) then
6180             difi=difi-drange(i)
6181             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6182             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6183           else if (difi.lt.-drange(i)) then
6184             difi=difi+drange(i)
6185             edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6186             gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6187           else
6188             difi=0.0
6189           endif
6190         enddo
6191       endif
6192       return
6193       end
6194 c----------------------------------------------------------------------------
6195 C The rigorous attempt to derive energy function
6196       subroutine ebend_kcc(etheta)
6197
6198       implicit real*8 (a-h,o-z)
6199       include 'DIMENSIONS'
6200       include 'COMMON.VAR'
6201       include 'COMMON.GEO'
6202       include 'COMMON.LOCAL'
6203       include 'COMMON.TORSION'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.DERIV'
6206       include 'COMMON.CHAIN'
6207       include 'COMMON.NAMES'
6208       include 'COMMON.IOUNITS'
6209       include 'COMMON.FFIELD'
6210       include 'COMMON.TORCNSTR'
6211       include 'COMMON.CONTROL'
6212       logical lprn
6213       double precision thybt1(maxang_kcc)
6214 C Set lprn=.true. for debugging
6215       lprn=energy_dec
6216 c     lprn=.true.
6217 C      print *,"wchodze kcc"
6218       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6219       etheta=0.0D0
6220       do i=ithet_start,ithet_end
6221 c        print *,i,itype(i-1),itype(i),itype(i-2)
6222         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6223      &  .or.itype(i).eq.ntyp1) cycle
6224         iti=iabs(itortyp(itype(i-1)))
6225         sinthet=dsin(theta(i))
6226         costhet=dcos(theta(i))
6227         do j=1,nbend_kcc_Tb(iti)
6228           thybt1(j)=v1bend_chyb(j,iti)
6229         enddo
6230         sumth1thyb=v1bend_chyb(0,iti)+
6231      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6232         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6233      &    sumth1thyb
6234         ihelp=nbend_kcc_Tb(iti)-1
6235         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6236         etheta=etheta+sumth1thyb
6237 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6238         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6239       enddo
6240       return
6241       end
6242 c-------------------------------------------------------------------------------------
6243       subroutine etheta_constr(ethetacnstr)
6244
6245       implicit real*8 (a-h,o-z)
6246       include 'DIMENSIONS'
6247       include 'COMMON.VAR'
6248       include 'COMMON.GEO'
6249       include 'COMMON.LOCAL'
6250       include 'COMMON.TORSION'
6251       include 'COMMON.INTERACT'
6252       include 'COMMON.DERIV'
6253       include 'COMMON.CHAIN'
6254       include 'COMMON.NAMES'
6255       include 'COMMON.IOUNITS'
6256       include 'COMMON.FFIELD'
6257       include 'COMMON.TORCNSTR'
6258       include 'COMMON.CONTROL'
6259       ethetacnstr=0.0d0
6260 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6261       do i=ithetaconstr_start,ithetaconstr_end
6262         itheta=itheta_constr(i)
6263         thetiii=theta(itheta)
6264         difi=pinorm(thetiii-theta_constr0(i))
6265         if (difi.gt.theta_drange(i)) then
6266           difi=difi-theta_drange(i)
6267           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6268           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6269      &    +for_thet_constr(i)*difi**3
6270         else if (difi.lt.-drange(i)) then
6271           difi=difi+drange(i)
6272           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6273           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6274      &    +for_thet_constr(i)*difi**3
6275         else
6276           difi=0.0
6277         endif
6278        if (energy_dec) then
6279         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6280      &    i,itheta,rad2deg*thetiii,
6281      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6282      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6283      &    gloc(itheta+nphi-2,icg)
6284         endif
6285       enddo
6286       return
6287       end
6288 c------------------------------------------------------------------------------
6289 c------------------------------------------------------------------------------
6290       subroutine eback_sc_corr(esccor)
6291 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6292 c        conformational states; temporarily implemented as differences
6293 c        between UNRES torsional potentials (dependent on three types of
6294 c        residues) and the torsional potentials dependent on all 20 types
6295 c        of residues computed from AM1 energy surfaces of terminally-blocked
6296 c        amino-acid residues.
6297       implicit real*8 (a-h,o-z)
6298       include 'DIMENSIONS'
6299       include 'COMMON.VAR'
6300       include 'COMMON.GEO'
6301       include 'COMMON.LOCAL'
6302       include 'COMMON.TORSION'
6303       include 'COMMON.SCCOR'
6304       include 'COMMON.INTERACT'
6305       include 'COMMON.DERIV'
6306       include 'COMMON.CHAIN'
6307       include 'COMMON.NAMES'
6308       include 'COMMON.IOUNITS'
6309       include 'COMMON.FFIELD'
6310       include 'COMMON.CONTROL'
6311       logical lprn
6312 C Set lprn=.true. for debugging
6313       lprn=.false.
6314 c      lprn=.true.
6315 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6316       esccor=0.0D0
6317       do i=itau_start,itau_end
6318         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6319         esccor_ii=0.0D0
6320         isccori=isccortyp(itype(i-2))
6321         isccori1=isccortyp(itype(i-1))
6322         phii=phi(i)
6323         do intertyp=1,3 !intertyp
6324 cc Added 09 May 2012 (Adasko)
6325 cc  Intertyp means interaction type of backbone mainchain correlation:
6326 c   1 = SC...Ca...Ca...Ca
6327 c   2 = Ca...Ca...Ca...SC
6328 c   3 = SC...Ca...Ca...SCi
6329         gloci=0.0D0
6330         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6331      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6332      &      (itype(i-1).eq.ntyp1)))
6333      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6334      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6335      &     .or.(itype(i).eq.ntyp1)))
6336      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6337      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6338      &      (itype(i-3).eq.ntyp1)))) cycle
6339         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6340         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6341      & cycle
6342        do j=1,nterm_sccor(isccori,isccori1)
6343           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6344           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6345           cosphi=dcos(j*tauangle(intertyp,i))
6346           sinphi=dsin(j*tauangle(intertyp,i))
6347            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6348            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6349          enddo
6350 C      write (iout,*)"EBACK_SC_COR",esccor,i
6351 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6352 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6353 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6354         if (lprn)
6355      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6356      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6357      &  (v1sccor(j,1,itori,itori1),j=1,6)
6358      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6359 c        gsccor_loc(i-3)=gloci
6360        enddo !intertyp
6361       enddo
6362       return
6363       end
6364 #ifdef FOURBODY
6365 c------------------------------------------------------------------------------
6366       subroutine multibody(ecorr)
6367 C This subroutine calculates multi-body contributions to energy following
6368 C the idea of Skolnick et al. If side chains I and J make a contact and
6369 C at the same time side chains I+1 and J+1 make a contact, an extra
6370 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6371       implicit real*8 (a-h,o-z)
6372       include 'DIMENSIONS'
6373       include 'COMMON.IOUNITS'
6374       include 'COMMON.DERIV'
6375       include 'COMMON.INTERACT'
6376       include 'COMMON.CONTACTS'
6377       include 'COMMON.CONTMAT'
6378       include 'COMMON.CORRMAT'
6379       double precision gx(3),gx1(3)
6380       logical lprn
6381
6382 C Set lprn=.true. for debugging
6383       lprn=.false.
6384
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values:'
6387         do i=nnt,nct-2
6388           write (iout,'(i2,20(1x,i2,f10.5))')
6389      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6390         enddo
6391       endif
6392       ecorr=0.0D0
6393       do i=nnt,nct
6394         do j=1,3
6395           gradcorr(j,i)=0.0D0
6396           gradxorr(j,i)=0.0D0
6397         enddo
6398       enddo
6399       do i=nnt,nct-2
6400
6401         DO ISHIFT = 3,4
6402
6403         i1=i+ishift
6404         num_conti=num_cont(i)
6405         num_conti1=num_cont(i1)
6406         do jj=1,num_conti
6407           j=jcont(jj,i)
6408           do kk=1,num_conti1
6409             j1=jcont(kk,i1)
6410             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6411 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6412 cd   &                   ' ishift=',ishift
6413 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6414 C The system gains extra energy.
6415               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6416             endif   ! j1==j+-ishift
6417           enddo     ! kk
6418         enddo       ! jj
6419
6420         ENDDO ! ISHIFT
6421
6422       enddo         ! i
6423       return
6424       end
6425 c------------------------------------------------------------------------------
6426       double precision function esccorr(i,j,k,l,jj,kk)
6427       implicit real*8 (a-h,o-z)
6428       include 'DIMENSIONS'
6429       include 'COMMON.IOUNITS'
6430       include 'COMMON.DERIV'
6431       include 'COMMON.INTERACT'
6432       include 'COMMON.CONTACTS'
6433       include 'COMMON.CONTMAT'
6434       include 'COMMON.CORRMAT'
6435       double precision gx(3),gx1(3)
6436       logical lprn
6437       lprn=.false.
6438       eij=facont(jj,i)
6439       ekl=facont(kk,k)
6440 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6441 C Calculate the multi-body contribution to energy.
6442 C Calculate multi-body contributions to the gradient.
6443 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6444 cd   & k,l,(gacont(m,kk,k),m=1,3)
6445       do m=1,3
6446         gx(m) =ekl*gacont(m,jj,i)
6447         gx1(m)=eij*gacont(m,kk,k)
6448         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6449         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6450         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6451         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6452       enddo
6453       do m=i,j-1
6454         do ll=1,3
6455           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6456         enddo
6457       enddo
6458       do m=k,l-1
6459         do ll=1,3
6460           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6461         enddo
6462       enddo
6463       esccorr=-eij*ekl
6464       return
6465       end
6466 c------------------------------------------------------------------------------
6467       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6468 C This subroutine calculates multi-body contributions to hydrogen-bonding
6469       implicit real*8 (a-h,o-z)
6470       include 'DIMENSIONS'
6471       include 'COMMON.IOUNITS'
6472       include 'COMMON.FFIELD'
6473       include 'COMMON.DERIV'
6474       include 'COMMON.INTERACT'
6475       include 'COMMON.CONTACTS'
6476       include 'COMMON.CONTMAT'
6477       include 'COMMON.CORRMAT'
6478       double precision gx(3),gx1(3)
6479       logical lprn,ldone
6480
6481 C Set lprn=.true. for debugging
6482       lprn=.false.
6483       if (lprn) then
6484         write (iout,'(a)') 'Contact function values:'
6485         do i=nnt,nct-2
6486           write (iout,'(2i3,50(1x,i2,f5.2))')
6487      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6488      &    j=1,num_cont_hb(i))
6489         enddo
6490       endif
6491       ecorr=0.0D0
6492 C Remove the loop below after debugging !!!
6493       do i=nnt,nct
6494         do j=1,3
6495           gradcorr(j,i)=0.0D0
6496           gradxorr(j,i)=0.0D0
6497         enddo
6498       enddo
6499 C Calculate the local-electrostatic correlation terms
6500       do i=iatel_s,iatel_e+1
6501         i1=i+1
6502         num_conti=num_cont_hb(i)
6503         num_conti1=num_cont_hb(i+1)
6504         do jj=1,num_conti
6505           j=jcont_hb(jj,i)
6506           do kk=1,num_conti1
6507             j1=jcont_hb(kk,i1)
6508 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6509 c     &         ' jj=',jj,' kk=',kk
6510             if (j1.eq.j+1 .or. j1.eq.j-1) then
6511 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6512 C The system gains extra energy.
6513               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6514               n_corr=n_corr+1
6515             else if (j1.eq.j) then
6516 C Contacts I-J and I-(J+1) occur simultaneously.
6517 C The system loses extra energy.
6518 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6519             endif
6520           enddo ! kk
6521           do kk=1,num_conti
6522             j1=jcont_hb(kk,i)
6523 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6524 c    &         ' jj=',jj,' kk=',kk
6525             if (j1.eq.j+1) then
6526 C Contacts I-J and (I+1)-J occur simultaneously.
6527 C The system loses extra energy.
6528 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6529             endif ! j1==j+1
6530           enddo ! kk
6531         enddo ! jj
6532       enddo ! i
6533       return
6534       end
6535 c------------------------------------------------------------------------------
6536       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6537      &  n_corr1)
6538 C This subroutine calculates multi-body contributions to hydrogen-bonding
6539       implicit real*8 (a-h,o-z)
6540       include 'DIMENSIONS'
6541       include 'COMMON.IOUNITS'
6542 #ifdef MPI
6543       include "mpif.h"
6544 #endif
6545       include 'COMMON.FFIELD'
6546       include 'COMMON.DERIV'
6547       include 'COMMON.LOCAL'
6548       include 'COMMON.INTERACT'
6549       include 'COMMON.CONTACTS'
6550       include 'COMMON.CONTMAT'
6551       include 'COMMON.CORRMAT'
6552       include 'COMMON.CHAIN'
6553       include 'COMMON.CONTROL'
6554       include 'COMMON.SHIELD'
6555       double precision gx(3),gx1(3)
6556       integer num_cont_hb_old(maxres)
6557       logical lprn,ldone
6558       double precision eello4,eello5,eelo6,eello_turn6
6559       external eello4,eello5,eello6,eello_turn6
6560 C Set lprn=.true. for debugging
6561       lprn=.false.
6562       eturn6=0.0d0
6563       if (lprn) then
6564         write (iout,'(a)') 'Contact function values:'
6565         do i=nnt,nct-2
6566           write (iout,'(2i3,50(1x,i2,5f6.3))')
6567      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6568      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6569         enddo
6570       endif
6571       ecorr=0.0D0
6572       ecorr5=0.0d0
6573       ecorr6=0.0d0
6574 C Remove the loop below after debugging !!!
6575       do i=nnt,nct
6576         do j=1,3
6577           gradcorr(j,i)=0.0D0
6578           gradxorr(j,i)=0.0D0
6579         enddo
6580       enddo
6581 C Calculate the dipole-dipole interaction energies
6582       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6583       do i=iatel_s,iatel_e+1
6584         num_conti=num_cont_hb(i)
6585         do jj=1,num_conti
6586           j=jcont_hb(jj,i)
6587 #ifdef MOMENT
6588           call dipole(i,j,jj)
6589 #endif
6590         enddo
6591       enddo
6592       endif
6593 C Calculate the local-electrostatic correlation terms
6594 c                write (iout,*) "gradcorr5 in eello5 before loop"
6595 c                do iii=1,nres
6596 c                  write (iout,'(i5,3f10.5)')
6597 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6598 c                enddo
6599       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6600 c        write (iout,*) "corr loop i",i
6601         i1=i+1
6602         num_conti=num_cont_hb(i)
6603         num_conti1=num_cont_hb(i+1)
6604         do jj=1,num_conti
6605           j=jcont_hb(jj,i)
6606           jp=iabs(j)
6607           do kk=1,num_conti1
6608             j1=jcont_hb(kk,i1)
6609             jp1=iabs(j1)
6610 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6611 c     &         ' jj=',jj,' kk=',kk
6612 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6613             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6614      &          .or. j.lt.0 .and. j1.gt.0) .and.
6615      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6616 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6617 C The system gains extra energy.
6618               n_corr=n_corr+1
6619               sqd1=dsqrt(d_cont(jj,i))
6620               sqd2=dsqrt(d_cont(kk,i1))
6621               sred_geom = sqd1*sqd2
6622               IF (sred_geom.lt.cutoff_corr) THEN
6623                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6624      &            ekont,fprimcont)
6625 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6626 cd     &         ' jj=',jj,' kk=',kk
6627                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6628                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6629                 do l=1,3
6630                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6631                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6632                 enddo
6633                 n_corr1=n_corr1+1
6634 cd               write (iout,*) 'sred_geom=',sred_geom,
6635 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6636 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6637 cd               write (iout,*) "g_contij",g_contij
6638 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6639 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6640                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6641                 if (wcorr4.gt.0.0d0)
6642      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6643 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6644                   if (energy_dec.and.wcorr4.gt.0.0d0)
6645      1                 write (iout,'(a6,4i5,0pf7.3)')
6646      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6647 c                write (iout,*) "gradcorr5 before eello5"
6648 c                do iii=1,nres
6649 c                  write (iout,'(i5,3f10.5)')
6650 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6651 c                enddo
6652                 if (wcorr5.gt.0.0d0)
6653      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6654 c                write (iout,*) "gradcorr5 after eello5"
6655 c                do iii=1,nres
6656 c                  write (iout,'(i5,3f10.5)')
6657 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6658 c                enddo
6659                   if (energy_dec.and.wcorr5.gt.0.0d0)
6660      1                 write (iout,'(a6,4i5,0pf7.3)')
6661      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6662 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6663 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6664                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6665      &               .or. wturn6.eq.0.0d0))then
6666 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6667                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6668                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6669      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6670 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6671 cd     &            'ecorr6=',ecorr6
6672 cd                write (iout,'(4e15.5)') sred_geom,
6673 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6674 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6675 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6676                 else if (wturn6.gt.0.0d0
6677      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6678 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6679                   eturn6=eturn6+eello_turn6(i,jj,kk)
6680                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6681      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6682 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6683                 endif
6684               ENDIF
6685 1111          continue
6686             endif
6687           enddo ! kk
6688         enddo ! jj
6689       enddo ! i
6690       do i=1,nres
6691         num_cont_hb(i)=num_cont_hb_old(i)
6692       enddo
6693 c                write (iout,*) "gradcorr5 in eello5"
6694 c                do iii=1,nres
6695 c                  write (iout,'(i5,3f10.5)')
6696 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6697 c                enddo
6698       return
6699       end
6700 c------------------------------------------------------------------------------
6701       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6702       implicit real*8 (a-h,o-z)
6703       include 'DIMENSIONS'
6704       include 'COMMON.IOUNITS'
6705       include 'COMMON.DERIV'
6706       include 'COMMON.INTERACT'
6707       include 'COMMON.CONTACTS'
6708       include 'COMMON.CONTMAT'
6709       include 'COMMON.CORRMAT'
6710       include 'COMMON.SHIELD'
6711       include 'COMMON.CONTROL'
6712       double precision gx(3),gx1(3)
6713       logical lprn
6714       lprn=.false.
6715 C      print *,"wchodze",fac_shield(i),shield_mode
6716       eij=facont_hb(jj,i)
6717       ekl=facont_hb(kk,k)
6718       ees0pij=ees0p(jj,i)
6719       ees0pkl=ees0p(kk,k)
6720       ees0mij=ees0m(jj,i)
6721       ees0mkl=ees0m(kk,k)
6722       ekont=eij*ekl
6723       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6724 C*
6725 C     & fac_shield(i)**2*fac_shield(j)**2
6726 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6727 C Following 4 lines for diagnostics.
6728 cd    ees0pkl=0.0D0
6729 cd    ees0pij=1.0D0
6730 cd    ees0mkl=0.0D0
6731 cd    ees0mij=1.0D0
6732 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6733 c     & 'Contacts ',i,j,
6734 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6735 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6736 c     & 'gradcorr_long'
6737 C Calculate the multi-body contribution to energy.
6738 C      ecorr=ecorr+ekont*ees
6739 C Calculate multi-body contributions to the gradient.
6740       coeffpees0pij=coeffp*ees0pij
6741       coeffmees0mij=coeffm*ees0mij
6742       coeffpees0pkl=coeffp*ees0pkl
6743       coeffmees0mkl=coeffm*ees0mkl
6744       do ll=1,3
6745 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6746         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6747      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6748      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6749         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6750      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6751      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6752 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6753         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6754      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6755      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6756         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6757      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6758      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6759         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6760      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6761      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6762         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6763         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6764         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6765      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6766      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6767         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6768         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6769 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6770       enddo
6771 c      write (iout,*)
6772 cgrad      do m=i+1,j-1
6773 cgrad        do ll=1,3
6774 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6775 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6776 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6777 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6778 cgrad        enddo
6779 cgrad      enddo
6780 cgrad      do m=k+1,l-1
6781 cgrad        do ll=1,3
6782 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6783 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6784 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6785 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6786 cgrad        enddo
6787 cgrad      enddo
6788 c      write (iout,*) "ehbcorr",ekont*ees
6789 C      print *,ekont,ees,i,k
6790       ehbcorr=ekont*ees
6791 C now gradient over shielding
6792 C      return
6793       if (shield_mode.gt.0) then
6794        j=ees0plist(jj,i)
6795        l=ees0plist(kk,k)
6796 C        print *,i,j,fac_shield(i),fac_shield(j),
6797 C     &fac_shield(k),fac_shield(l)
6798         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6799      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6800           do ilist=1,ishield_list(i)
6801            iresshield=shield_list(ilist,i)
6802            do m=1,3
6803            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6804 C     &      *2.0
6805            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6806      &              rlocshield
6807      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6808             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6809      &+rlocshield
6810            enddo
6811           enddo
6812           do ilist=1,ishield_list(j)
6813            iresshield=shield_list(ilist,j)
6814            do m=1,3
6815            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6816 C     &     *2.0
6817            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6818      &              rlocshield
6819      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6820            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6821      &     +rlocshield
6822            enddo
6823           enddo
6824
6825           do ilist=1,ishield_list(k)
6826            iresshield=shield_list(ilist,k)
6827            do m=1,3
6828            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6829 C     &     *2.0
6830            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6831      &              rlocshield
6832      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6833            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6834      &     +rlocshield
6835            enddo
6836           enddo
6837           do ilist=1,ishield_list(l)
6838            iresshield=shield_list(ilist,l)
6839            do m=1,3
6840            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6841 C     &     *2.0
6842            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6843      &              rlocshield
6844      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6845            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6846      &     +rlocshield
6847            enddo
6848           enddo
6849 C          print *,gshieldx(m,iresshield)
6850           do m=1,3
6851             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6852      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6853             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6854      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6855             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6856      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6857             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6858      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6859
6860             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6861      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6862             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6863      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6864             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6865      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6866             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6867      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6868
6869            enddo
6870       endif
6871       endif
6872       return
6873       end
6874 #ifdef MOMENT
6875 C---------------------------------------------------------------------------
6876       subroutine dipole(i,j,jj)
6877       implicit real*8 (a-h,o-z)
6878       include 'DIMENSIONS'
6879       include 'COMMON.IOUNITS'
6880       include 'COMMON.CHAIN'
6881       include 'COMMON.FFIELD'
6882       include 'COMMON.DERIV'
6883       include 'COMMON.INTERACT'
6884       include 'COMMON.CONTACTS'
6885       include 'COMMON.CONTMAT'
6886       include 'COMMON.CORRMAT'
6887       include 'COMMON.TORSION'
6888       include 'COMMON.VAR'
6889       include 'COMMON.GEO'
6890       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6891      &  auxmat(2,2)
6892       iti1 = itortyp(itype(i+1))
6893       if (j.lt.nres-1) then
6894         itj1 = itype2loc(itype(j+1))
6895       else
6896         itj1=nloctyp
6897       endif
6898       do iii=1,2
6899         dipi(iii,1)=Ub2(iii,i)
6900         dipderi(iii)=Ub2der(iii,i)
6901         dipi(iii,2)=b1(iii,i+1)
6902         dipj(iii,1)=Ub2(iii,j)
6903         dipderj(iii)=Ub2der(iii,j)
6904         dipj(iii,2)=b1(iii,j+1)
6905       enddo
6906       kkk=0
6907       do iii=1,2
6908         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6909         do jjj=1,2
6910           kkk=kkk+1
6911           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6912         enddo
6913       enddo
6914       do kkk=1,5
6915         do lll=1,3
6916           mmm=0
6917           do iii=1,2
6918             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6919      &        auxvec(1))
6920             do jjj=1,2
6921               mmm=mmm+1
6922               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6923             enddo
6924           enddo
6925         enddo
6926       enddo
6927       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6928       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6929       do iii=1,2
6930         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6931       enddo
6932       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6933       do iii=1,2
6934         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6935       enddo
6936       return
6937       end
6938 #endif
6939 C---------------------------------------------------------------------------
6940       subroutine calc_eello(i,j,k,l,jj,kk)
6941 C
6942 C This subroutine computes matrices and vectors needed to calculate
6943 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6944 C
6945       implicit real*8 (a-h,o-z)
6946       include 'DIMENSIONS'
6947       include 'COMMON.IOUNITS'
6948       include 'COMMON.CHAIN'
6949       include 'COMMON.DERIV'
6950       include 'COMMON.INTERACT'
6951       include 'COMMON.CONTACTS'
6952       include 'COMMON.CONTMAT'
6953       include 'COMMON.CORRMAT'
6954       include 'COMMON.TORSION'
6955       include 'COMMON.VAR'
6956       include 'COMMON.GEO'
6957       include 'COMMON.FFIELD'
6958       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6959      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6960       logical lprn
6961       common /kutas/ lprn
6962 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6963 cd     & ' jj=',jj,' kk=',kk
6964 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6965 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6966 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6967       do iii=1,2
6968         do jjj=1,2
6969           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6970           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6971         enddo
6972       enddo
6973       call transpose2(aa1(1,1),aa1t(1,1))
6974       call transpose2(aa2(1,1),aa2t(1,1))
6975       do kkk=1,5
6976         do lll=1,3
6977           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6978      &      aa1tder(1,1,lll,kkk))
6979           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6980      &      aa2tder(1,1,lll,kkk))
6981         enddo
6982       enddo
6983       if (l.eq.j+1) then
6984 C parallel orientation of the two CA-CA-CA frames.
6985         if (i.gt.1) then
6986           iti=itype2loc(itype(i))
6987         else
6988           iti=nloctyp
6989         endif
6990         itk1=itype2loc(itype(k+1))
6991         itj=itype2loc(itype(j))
6992         if (l.lt.nres-1) then
6993           itl1=itype2loc(itype(l+1))
6994         else
6995           itl1=nloctyp
6996         endif
6997 C A1 kernel(j+1) A2T
6998 cd        do iii=1,2
6999 cd          write (iout,'(3f10.5,5x,3f10.5)')
7000 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7001 cd        enddo
7002         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7003      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7004      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7005 C Following matrices are needed only for 6-th order cumulants
7006         IF (wcorr6.gt.0.0d0) THEN
7007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7008      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7009      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7010         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7011      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7012      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7013      &   ADtEAderx(1,1,1,1,1,1))
7014         lprn=.false.
7015         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7016      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7017      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7018      &   ADtEA1derx(1,1,1,1,1,1))
7019         ENDIF
7020 C End 6-th order cumulants
7021 cd        lprn=.false.
7022 cd        if (lprn) then
7023 cd        write (2,*) 'In calc_eello6'
7024 cd        do iii=1,2
7025 cd          write (2,*) 'iii=',iii
7026 cd          do kkk=1,5
7027 cd            write (2,*) 'kkk=',kkk
7028 cd            do jjj=1,2
7029 cd              write (2,'(3(2f10.5),5x)')
7030 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7031 cd            enddo
7032 cd          enddo
7033 cd        enddo
7034 cd        endif
7035         call transpose2(EUgder(1,1,k),auxmat(1,1))
7036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7037         call transpose2(EUg(1,1,k),auxmat(1,1))
7038         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7039         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7040         do iii=1,2
7041           do kkk=1,5
7042             do lll=1,3
7043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7044      &          EAEAderx(1,1,lll,kkk,iii,1))
7045             enddo
7046           enddo
7047         enddo
7048 C A1T kernel(i+1) A2
7049         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7050      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7051      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7052 C Following matrices are needed only for 6-th order cumulants
7053         IF (wcorr6.gt.0.0d0) THEN
7054         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7055      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7056      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7057         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7058      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7059      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7060      &   ADtEAderx(1,1,1,1,1,2))
7061         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7062      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7063      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7064      &   ADtEA1derx(1,1,1,1,1,2))
7065         ENDIF
7066 C End 6-th order cumulants
7067         call transpose2(EUgder(1,1,l),auxmat(1,1))
7068         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7069         call transpose2(EUg(1,1,l),auxmat(1,1))
7070         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7071         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7072         do iii=1,2
7073           do kkk=1,5
7074             do lll=1,3
7075               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7076      &          EAEAderx(1,1,lll,kkk,iii,2))
7077             enddo
7078           enddo
7079         enddo
7080 C AEAb1 and AEAb2
7081 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7082 C They are needed only when the fifth- or the sixth-order cumulants are
7083 C indluded.
7084         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7085         call transpose2(AEA(1,1,1),auxmat(1,1))
7086         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7087         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7088         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7089         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7090         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7091         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7092         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7093         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7094         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7095         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7096         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7097         call transpose2(AEA(1,1,2),auxmat(1,1))
7098         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7099         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7100         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7101         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7102         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7103         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7104         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7105         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7106         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7107         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7108         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7109 C Calculate the Cartesian derivatives of the vectors.
7110         do iii=1,2
7111           do kkk=1,5
7112             do lll=1,3
7113               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7114               call matvec2(auxmat(1,1),b1(1,i),
7115      &          AEAb1derx(1,lll,kkk,iii,1,1))
7116               call matvec2(auxmat(1,1),Ub2(1,i),
7117      &          AEAb2derx(1,lll,kkk,iii,1,1))
7118               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7119      &          AEAb1derx(1,lll,kkk,iii,2,1))
7120               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7121      &          AEAb2derx(1,lll,kkk,iii,2,1))
7122               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7123               call matvec2(auxmat(1,1),b1(1,j),
7124      &          AEAb1derx(1,lll,kkk,iii,1,2))
7125               call matvec2(auxmat(1,1),Ub2(1,j),
7126      &          AEAb2derx(1,lll,kkk,iii,1,2))
7127               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7128      &          AEAb1derx(1,lll,kkk,iii,2,2))
7129               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7130      &          AEAb2derx(1,lll,kkk,iii,2,2))
7131             enddo
7132           enddo
7133         enddo
7134         ENDIF
7135 C End vectors
7136       else
7137 C Antiparallel orientation of the two CA-CA-CA frames.
7138         if (i.gt.1) then
7139           iti=itype2loc(itype(i))
7140         else
7141           iti=nloctyp
7142         endif
7143         itk1=itype2loc(itype(k+1))
7144         itl=itype2loc(itype(l))
7145         itj=itype2loc(itype(j))
7146         if (j.lt.nres-1) then
7147           itj1=itype2loc(itype(j+1))
7148         else
7149           itj1=nloctyp
7150         endif
7151 C A2 kernel(j-1)T A1T
7152         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7153      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7154      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7155 C Following matrices are needed only for 6-th order cumulants
7156         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7157      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7160      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7161         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7162      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7163      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7164      &   ADtEAderx(1,1,1,1,1,1))
7165         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7166      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7167      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7168      &   ADtEA1derx(1,1,1,1,1,1))
7169         ENDIF
7170 C End 6-th order cumulants
7171         call transpose2(EUgder(1,1,k),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7173         call transpose2(EUg(1,1,k),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7175         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7180      &          EAEAderx(1,1,lll,kkk,iii,1))
7181             enddo
7182           enddo
7183         enddo
7184 C A2T kernel(i+1)T A1
7185         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7186      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7187      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7188 C Following matrices are needed only for 6-th order cumulants
7189         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7190      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7193      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7194         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7195      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7196      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7197      &   ADtEAderx(1,1,1,1,1,2))
7198         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7199      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7200      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7201      &   ADtEA1derx(1,1,1,1,1,2))
7202         ENDIF
7203 C End 6-th order cumulants
7204         call transpose2(EUgder(1,1,j),auxmat(1,1))
7205         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7206         call transpose2(EUg(1,1,j),auxmat(1,1))
7207         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7208         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7213      &          EAEAderx(1,1,lll,kkk,iii,2))
7214             enddo
7215           enddo
7216         enddo
7217 C AEAb1 and AEAb2
7218 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7219 C They are needed only when the fifth- or the sixth-order cumulants are
7220 C indluded.
7221         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7222      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7223         call transpose2(AEA(1,1,1),auxmat(1,1))
7224         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7225         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7226         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7227         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7228         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7229         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7230         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7231         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7232         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7233         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7234         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7235         call transpose2(AEA(1,1,2),auxmat(1,1))
7236         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7237         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7238         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7239         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7240         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7241         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7242         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7243         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7244         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7245         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7246         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7247 C Calculate the Cartesian derivatives of the vectors.
7248         do iii=1,2
7249           do kkk=1,5
7250             do lll=1,3
7251               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7252               call matvec2(auxmat(1,1),b1(1,i),
7253      &          AEAb1derx(1,lll,kkk,iii,1,1))
7254               call matvec2(auxmat(1,1),Ub2(1,i),
7255      &          AEAb2derx(1,lll,kkk,iii,1,1))
7256               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7257      &          AEAb1derx(1,lll,kkk,iii,2,1))
7258               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7259      &          AEAb2derx(1,lll,kkk,iii,2,1))
7260               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7261               call matvec2(auxmat(1,1),b1(1,l),
7262      &          AEAb1derx(1,lll,kkk,iii,1,2))
7263               call matvec2(auxmat(1,1),Ub2(1,l),
7264      &          AEAb2derx(1,lll,kkk,iii,1,2))
7265               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7266      &          AEAb1derx(1,lll,kkk,iii,2,2))
7267               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7268      &          AEAb2derx(1,lll,kkk,iii,2,2))
7269             enddo
7270           enddo
7271         enddo
7272         ENDIF
7273 C End vectors
7274       endif
7275       return
7276       end
7277 C---------------------------------------------------------------------------
7278       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7279      &  KK,KKderg,AKA,AKAderg,AKAderx)
7280       implicit none
7281       integer nderg
7282       logical transp
7283       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7284      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7285      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7286       integer iii,kkk,lll
7287       integer jjj,mmm
7288       logical lprn
7289       common /kutas/ lprn
7290       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7291       do iii=1,nderg
7292         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7293      &    AKAderg(1,1,iii))
7294       enddo
7295 cd      if (lprn) write (2,*) 'In kernel'
7296       do kkk=1,5
7297 cd        if (lprn) write (2,*) 'kkk=',kkk
7298         do lll=1,3
7299           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7300      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7301 cd          if (lprn) then
7302 cd            write (2,*) 'lll=',lll
7303 cd            write (2,*) 'iii=1'
7304 cd            do jjj=1,2
7305 cd              write (2,'(3(2f10.5),5x)')
7306 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7307 cd            enddo
7308 cd          endif
7309           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7310      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7311 cd          if (lprn) then
7312 cd            write (2,*) 'lll=',lll
7313 cd            write (2,*) 'iii=2'
7314 cd            do jjj=1,2
7315 cd              write (2,'(3(2f10.5),5x)')
7316 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7317 cd            enddo
7318 cd          endif
7319         enddo
7320       enddo
7321       return
7322       end
7323 C---------------------------------------------------------------------------
7324       double precision function eello4(i,j,k,l,jj,kk)
7325       implicit real*8 (a-h,o-z)
7326       include 'DIMENSIONS'
7327       include 'COMMON.IOUNITS'
7328       include 'COMMON.CHAIN'
7329       include 'COMMON.DERIV'
7330       include 'COMMON.INTERACT'
7331       include 'COMMON.CONTACTS'
7332       include 'COMMON.CONTMAT'
7333       include 'COMMON.CORRMAT'
7334       include 'COMMON.TORSION'
7335       include 'COMMON.VAR'
7336       include 'COMMON.GEO'
7337       double precision pizda(2,2),ggg1(3),ggg2(3)
7338 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7339 cd        eello4=0.0d0
7340 cd        return
7341 cd      endif
7342 cd      print *,'eello4:',i,j,k,l,jj,kk
7343 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7344 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7345 cold      eij=facont_hb(jj,i)
7346 cold      ekl=facont_hb(kk,k)
7347 cold      ekont=eij*ekl
7348       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7349       if (calc_grad) then
7350 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7351       gcorr_loc(k-1)=gcorr_loc(k-1)
7352      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7353       if (l.eq.j+1) then
7354         gcorr_loc(l-1)=gcorr_loc(l-1)
7355      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7356       else
7357         gcorr_loc(j-1)=gcorr_loc(j-1)
7358      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7359       endif
7360       do iii=1,2
7361         do kkk=1,5
7362           do lll=1,3
7363             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7364      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7365 cd            derx(lll,kkk,iii)=0.0d0
7366           enddo
7367         enddo
7368       enddo
7369 cd      gcorr_loc(l-1)=0.0d0
7370 cd      gcorr_loc(j-1)=0.0d0
7371 cd      gcorr_loc(k-1)=0.0d0
7372 cd      eel4=1.0d0
7373 cd      write (iout,*)'Contacts have occurred for peptide groups',
7374 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7375 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7376       if (j.lt.nres-1) then
7377         j1=j+1
7378         j2=j-1
7379       else
7380         j1=j-1
7381         j2=j-2
7382       endif
7383       if (l.lt.nres-1) then
7384         l1=l+1
7385         l2=l-1
7386       else
7387         l1=l-1
7388         l2=l-2
7389       endif
7390       do ll=1,3
7391 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7392 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7393         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7394         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7395 cgrad        ghalf=0.5d0*ggg1(ll)
7396         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7397         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7398         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7399         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7400         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7401         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7402 cgrad        ghalf=0.5d0*ggg2(ll)
7403         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7404         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7405         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7406         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7407         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7408         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7409       enddo
7410 cgrad      do m=i+1,j-1
7411 cgrad        do ll=1,3
7412 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7413 cgrad        enddo
7414 cgrad      enddo
7415 cgrad      do m=k+1,l-1
7416 cgrad        do ll=1,3
7417 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7418 cgrad        enddo
7419 cgrad      enddo
7420 cgrad      do m=i+2,j2
7421 cgrad        do ll=1,3
7422 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7423 cgrad        enddo
7424 cgrad      enddo
7425 cgrad      do m=k+2,l2
7426 cgrad        do ll=1,3
7427 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7428 cgrad        enddo
7429 cgrad      enddo
7430 cd      do iii=1,nres-3
7431 cd        write (2,*) iii,gcorr_loc(iii)
7432 cd      enddo
7433       endif ! calc_grad
7434       eello4=ekont*eel4
7435 cd      write (2,*) 'ekont',ekont
7436 cd      write (iout,*) 'eello4',ekont*eel4
7437       return
7438       end
7439 C---------------------------------------------------------------------------
7440       double precision function eello5(i,j,k,l,jj,kk)
7441       implicit real*8 (a-h,o-z)
7442       include 'DIMENSIONS'
7443       include 'COMMON.IOUNITS'
7444       include 'COMMON.CHAIN'
7445       include 'COMMON.DERIV'
7446       include 'COMMON.INTERACT'
7447       include 'COMMON.CONTACTS'
7448       include 'COMMON.CONTMAT'
7449       include 'COMMON.CORRMAT'
7450       include 'COMMON.TORSION'
7451       include 'COMMON.VAR'
7452       include 'COMMON.GEO'
7453       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7454       double precision ggg1(3),ggg2(3)
7455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7456 C                                                                              C
7457 C                            Parallel chains                                   C
7458 C                                                                              C
7459 C          o             o                   o             o                   C
7460 C         /l\           / \             \   / \           / \   /              C
7461 C        /   \         /   \             \ /   \         /   \ /               C
7462 C       j| o |l1       | o |              o| o |         | o |o                C
7463 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7464 C      \i/   \         /   \ /             /   \         /   \                 C
7465 C       o    k1             o                                                  C
7466 C         (I)          (II)                (III)          (IV)                 C
7467 C                                                                              C
7468 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7469 C                                                                              C
7470 C                            Antiparallel chains                               C
7471 C                                                                              C
7472 C          o             o                   o             o                   C
7473 C         /j\           / \             \   / \           / \   /              C
7474 C        /   \         /   \             \ /   \         /   \ /               C
7475 C      j1| o |l        | o |              o| o |         | o |o                C
7476 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7477 C      \i/   \         /   \ /             /   \         /   \                 C
7478 C       o     k1            o                                                  C
7479 C         (I)          (II)                (III)          (IV)                 C
7480 C                                                                              C
7481 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7482 C                                                                              C
7483 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7484 C                                                                              C
7485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7486 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7487 cd        eello5=0.0d0
7488 cd        return
7489 cd      endif
7490 cd      write (iout,*)
7491 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7492 cd     &   ' and',k,l
7493       itk=itype2loc(itype(k))
7494       itl=itype2loc(itype(l))
7495       itj=itype2loc(itype(j))
7496       eello5_1=0.0d0
7497       eello5_2=0.0d0
7498       eello5_3=0.0d0
7499       eello5_4=0.0d0
7500 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7501 cd     &   eel5_3_num,eel5_4_num)
7502       do iii=1,2
7503         do kkk=1,5
7504           do lll=1,3
7505             derx(lll,kkk,iii)=0.0d0
7506           enddo
7507         enddo
7508       enddo
7509 cd      eij=facont_hb(jj,i)
7510 cd      ekl=facont_hb(kk,k)
7511 cd      ekont=eij*ekl
7512 cd      write (iout,*)'Contacts have occurred for peptide groups',
7513 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7514 cd      goto 1111
7515 C Contribution from the graph I.
7516 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7517 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7518       call transpose2(EUg(1,1,k),auxmat(1,1))
7519       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7520       vv(1)=pizda(1,1)-pizda(2,2)
7521       vv(2)=pizda(1,2)+pizda(2,1)
7522       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7523      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7524       if (calc_grad) then
7525 C Explicit gradient in virtual-dihedral angles.
7526       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7527      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7528      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7529       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7530       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7531       vv(1)=pizda(1,1)-pizda(2,2)
7532       vv(2)=pizda(1,2)+pizda(2,1)
7533       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7534      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7535      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7536       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7537       vv(1)=pizda(1,1)-pizda(2,2)
7538       vv(2)=pizda(1,2)+pizda(2,1)
7539       if (l.eq.j+1) then
7540         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7541      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7542      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7543       else
7544         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7545      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7546      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7547       endif
7548 C Cartesian gradient
7549       do iii=1,2
7550         do kkk=1,5
7551           do lll=1,3
7552             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7553      &        pizda(1,1))
7554             vv(1)=pizda(1,1)-pizda(2,2)
7555             vv(2)=pizda(1,2)+pizda(2,1)
7556             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7557      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7558      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7559           enddo
7560         enddo
7561       enddo
7562       endif ! calc_grad
7563 c      goto 1112
7564 c1111  continue
7565 C Contribution from graph II
7566       call transpose2(EE(1,1,k),auxmat(1,1))
7567       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7568       vv(1)=pizda(1,1)+pizda(2,2)
7569       vv(2)=pizda(2,1)-pizda(1,2)
7570       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7571      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7572       if (calc_grad) then
7573 C Explicit gradient in virtual-dihedral angles.
7574       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7575      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7576       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7577       vv(1)=pizda(1,1)+pizda(2,2)
7578       vv(2)=pizda(2,1)-pizda(1,2)
7579       if (l.eq.j+1) then
7580         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7581      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7582      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7583       else
7584         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7585      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7586      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7587       endif
7588 C Cartesian gradient
7589       do iii=1,2
7590         do kkk=1,5
7591           do lll=1,3
7592             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7593      &        pizda(1,1))
7594             vv(1)=pizda(1,1)+pizda(2,2)
7595             vv(2)=pizda(2,1)-pizda(1,2)
7596             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7597      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7598      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7599           enddo
7600         enddo
7601       enddo
7602       endif ! calc_grad
7603 cd      goto 1112
7604 cd1111  continue
7605       if (l.eq.j+1) then
7606 cd        goto 1110
7607 C Parallel orientation
7608 C Contribution from graph III
7609         call transpose2(EUg(1,1,l),auxmat(1,1))
7610         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7611         vv(1)=pizda(1,1)-pizda(2,2)
7612         vv(2)=pizda(1,2)+pizda(2,1)
7613         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7615         if (calc_grad) then
7616 C Explicit gradient in virtual-dihedral angles.
7617         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7618      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7619      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7620         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7621         vv(1)=pizda(1,1)-pizda(2,2)
7622         vv(2)=pizda(1,2)+pizda(2,1)
7623         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7624      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7625      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7626         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7627         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7628         vv(1)=pizda(1,1)-pizda(2,2)
7629         vv(2)=pizda(1,2)+pizda(2,1)
7630         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7631      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7633 C Cartesian gradient
7634         do iii=1,2
7635           do kkk=1,5
7636             do lll=1,3
7637               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7638      &          pizda(1,1))
7639               vv(1)=pizda(1,1)-pizda(2,2)
7640               vv(2)=pizda(1,2)+pizda(2,1)
7641               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7642      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7643      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7644             enddo
7645           enddo
7646         enddo
7647 cd        goto 1112
7648 C Contribution from graph IV
7649 cd1110    continue
7650         call transpose2(EE(1,1,l),auxmat(1,1))
7651         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7652         vv(1)=pizda(1,1)+pizda(2,2)
7653         vv(2)=pizda(2,1)-pizda(1,2)
7654         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7655      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7656 C Explicit gradient in virtual-dihedral angles.
7657         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7658      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7659         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7660         vv(1)=pizda(1,1)+pizda(2,2)
7661         vv(2)=pizda(2,1)-pizda(1,2)
7662         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7663      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7664      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7665 C Cartesian gradient
7666         do iii=1,2
7667           do kkk=1,5
7668             do lll=1,3
7669               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7670      &          pizda(1,1))
7671               vv(1)=pizda(1,1)+pizda(2,2)
7672               vv(2)=pizda(2,1)-pizda(1,2)
7673               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7674      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7675      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7676             enddo
7677           enddo
7678         enddo
7679         endif ! calc_grad
7680       else
7681 C Antiparallel orientation
7682 C Contribution from graph III
7683 c        goto 1110
7684         call transpose2(EUg(1,1,j),auxmat(1,1))
7685         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7686         vv(1)=pizda(1,1)-pizda(2,2)
7687         vv(2)=pizda(1,2)+pizda(2,1)
7688         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7689      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7690         if (calc_grad) then
7691 C Explicit gradient in virtual-dihedral angles.
7692         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7693      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7694      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7695         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7696         vv(1)=pizda(1,1)-pizda(2,2)
7697         vv(2)=pizda(1,2)+pizda(2,1)
7698         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7699      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7700      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7701         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7702         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7703         vv(1)=pizda(1,1)-pizda(2,2)
7704         vv(2)=pizda(1,2)+pizda(2,1)
7705         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7706      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7707      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7708 C Cartesian gradient
7709         do iii=1,2
7710           do kkk=1,5
7711             do lll=1,3
7712               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7713      &          pizda(1,1))
7714               vv(1)=pizda(1,1)-pizda(2,2)
7715               vv(2)=pizda(1,2)+pizda(2,1)
7716               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7717      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7718      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7719             enddo
7720           enddo
7721         enddo
7722         endif ! calc_grad
7723 cd        goto 1112
7724 C Contribution from graph IV
7725 1110    continue
7726         call transpose2(EE(1,1,j),auxmat(1,1))
7727         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7728         vv(1)=pizda(1,1)+pizda(2,2)
7729         vv(2)=pizda(2,1)-pizda(1,2)
7730         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7731      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7732         if (calc_grad) then
7733 C Explicit gradient in virtual-dihedral angles.
7734         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7735      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7736         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7737         vv(1)=pizda(1,1)+pizda(2,2)
7738         vv(2)=pizda(2,1)-pizda(1,2)
7739         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7740      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7741      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7742 C Cartesian gradient
7743         do iii=1,2
7744           do kkk=1,5
7745             do lll=1,3
7746               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7747      &          pizda(1,1))
7748               vv(1)=pizda(1,1)+pizda(2,2)
7749               vv(2)=pizda(2,1)-pizda(1,2)
7750               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7751      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7752      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7753             enddo
7754           enddo
7755         enddo
7756         endif ! calc_grad
7757       endif
7758 1112  continue
7759       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7760 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7761 cd        write (2,*) 'ijkl',i,j,k,l
7762 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7763 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7764 cd      endif
7765 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7766 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7767 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7768 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7769       if (calc_grad) then
7770       if (j.lt.nres-1) then
7771         j1=j+1
7772         j2=j-1
7773       else
7774         j1=j-1
7775         j2=j-2
7776       endif
7777       if (l.lt.nres-1) then
7778         l1=l+1
7779         l2=l-1
7780       else
7781         l1=l-1
7782         l2=l-2
7783       endif
7784 cd      eij=1.0d0
7785 cd      ekl=1.0d0
7786 cd      ekont=1.0d0
7787 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7788 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7789 C        summed up outside the subrouine as for the other subroutines
7790 C        handling long-range interactions. The old code is commented out
7791 C        with "cgrad" to keep track of changes.
7792       do ll=1,3
7793 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7794 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7795         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7796         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7797 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7798 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7799 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7800 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7801 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7802 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7803 c     &   gradcorr5ij,
7804 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7805 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7806 cgrad        ghalf=0.5d0*ggg1(ll)
7807 cd        ghalf=0.0d0
7808         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7809         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7810         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7811         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7812         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7813         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7814 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7815 cgrad        ghalf=0.5d0*ggg2(ll)
7816 cd        ghalf=0.0d0
7817         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7818         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7819         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7820         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7821         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7822         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7823       enddo
7824       endif ! calc_grad
7825 cd      goto 1112
7826 cgrad      do m=i+1,j-1
7827 cgrad        do ll=1,3
7828 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7829 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7830 cgrad        enddo
7831 cgrad      enddo
7832 cgrad      do m=k+1,l-1
7833 cgrad        do ll=1,3
7834 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7835 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7836 cgrad        enddo
7837 cgrad      enddo
7838 c1112  continue
7839 cgrad      do m=i+2,j2
7840 cgrad        do ll=1,3
7841 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7842 cgrad        enddo
7843 cgrad      enddo
7844 cgrad      do m=k+2,l2
7845 cgrad        do ll=1,3
7846 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7847 cgrad        enddo
7848 cgrad      enddo
7849 cd      do iii=1,nres-3
7850 cd        write (2,*) iii,g_corr5_loc(iii)
7851 cd      enddo
7852       eello5=ekont*eel5
7853 cd      write (2,*) 'ekont',ekont
7854 cd      write (iout,*) 'eello5',ekont*eel5
7855       return
7856       end
7857 c--------------------------------------------------------------------------
7858       double precision function eello6(i,j,k,l,jj,kk)
7859       implicit real*8 (a-h,o-z)
7860       include 'DIMENSIONS'
7861       include 'COMMON.IOUNITS'
7862       include 'COMMON.CHAIN'
7863       include 'COMMON.DERIV'
7864       include 'COMMON.INTERACT'
7865       include 'COMMON.CONTACTS'
7866       include 'COMMON.CONTMAT'
7867       include 'COMMON.CORRMAT'
7868       include 'COMMON.TORSION'
7869       include 'COMMON.VAR'
7870       include 'COMMON.GEO'
7871       include 'COMMON.FFIELD'
7872       double precision ggg1(3),ggg2(3)
7873 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7874 cd        eello6=0.0d0
7875 cd        return
7876 cd      endif
7877 cd      write (iout,*)
7878 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7879 cd     &   ' and',k,l
7880       eello6_1=0.0d0
7881       eello6_2=0.0d0
7882       eello6_3=0.0d0
7883       eello6_4=0.0d0
7884       eello6_5=0.0d0
7885       eello6_6=0.0d0
7886 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7887 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7888       do iii=1,2
7889         do kkk=1,5
7890           do lll=1,3
7891             derx(lll,kkk,iii)=0.0d0
7892           enddo
7893         enddo
7894       enddo
7895 cd      eij=facont_hb(jj,i)
7896 cd      ekl=facont_hb(kk,k)
7897 cd      ekont=eij*ekl
7898 cd      eij=1.0d0
7899 cd      ekl=1.0d0
7900 cd      ekont=1.0d0
7901       if (l.eq.j+1) then
7902         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7903         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7904         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7905         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7906         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7907         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7908       else
7909         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7910         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7911         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7912         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7913         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7914           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7915         else
7916           eello6_5=0.0d0
7917         endif
7918         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7919       endif
7920 C If turn contributions are considered, they will be handled separately.
7921       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7922 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7923 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7924 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7925 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7926 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7927 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7928 cd      goto 1112
7929       if (calc_grad) then
7930       if (j.lt.nres-1) then
7931         j1=j+1
7932         j2=j-1
7933       else
7934         j1=j-1
7935         j2=j-2
7936       endif
7937       if (l.lt.nres-1) then
7938         l1=l+1
7939         l2=l-1
7940       else
7941         l1=l-1
7942         l2=l-2
7943       endif
7944       do ll=1,3
7945 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7946 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7947 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7948 cgrad        ghalf=0.5d0*ggg1(ll)
7949 cd        ghalf=0.0d0
7950         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7951         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7952         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7953         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7954         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7955         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7956         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7957         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7958 cgrad        ghalf=0.5d0*ggg2(ll)
7959 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7960 cd        ghalf=0.0d0
7961         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7962         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7963         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7964         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7965         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7966         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7967       enddo
7968       endif ! calc_grad
7969 cd      goto 1112
7970 cgrad      do m=i+1,j-1
7971 cgrad        do ll=1,3
7972 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7973 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7974 cgrad        enddo
7975 cgrad      enddo
7976 cgrad      do m=k+1,l-1
7977 cgrad        do ll=1,3
7978 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7979 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7980 cgrad        enddo
7981 cgrad      enddo
7982 cgrad1112  continue
7983 cgrad      do m=i+2,j2
7984 cgrad        do ll=1,3
7985 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cgrad      do m=k+2,l2
7989 cgrad        do ll=1,3
7990 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7991 cgrad        enddo
7992 cgrad      enddo
7993 cd      do iii=1,nres-3
7994 cd        write (2,*) iii,g_corr6_loc(iii)
7995 cd      enddo
7996       eello6=ekont*eel6
7997 cd      write (2,*) 'ekont',ekont
7998 cd      write (iout,*) 'eello6',ekont*eel6
7999       return
8000       end
8001 c--------------------------------------------------------------------------
8002       double precision function eello6_graph1(i,j,k,l,imat,swap)
8003       implicit real*8 (a-h,o-z)
8004       include 'DIMENSIONS'
8005       include 'COMMON.IOUNITS'
8006       include 'COMMON.CHAIN'
8007       include 'COMMON.DERIV'
8008       include 'COMMON.INTERACT'
8009       include 'COMMON.CONTACTS'
8010       include 'COMMON.CONTMAT'
8011       include 'COMMON.CORRMAT'
8012       include 'COMMON.TORSION'
8013       include 'COMMON.VAR'
8014       include 'COMMON.GEO'
8015       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8016       logical swap
8017       logical lprn
8018       common /kutas/ lprn
8019 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8020 C                                                                              C
8021 C      Parallel       Antiparallel                                             C
8022 C                                                                              C
8023 C          o             o                                                     C
8024 C         /l\           /j\                                                    C
8025 C        /   \         /   \                                                   C
8026 C       /| o |         | o |\                                                  C
8027 C     \ j|/k\|  /   \  |/k\|l /                                                C
8028 C      \ /   \ /     \ /   \ /                                                 C
8029 C       o     o       o     o                                                  C
8030 C       i             i                                                        C
8031 C                                                                              C
8032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8033       itk=itype2loc(itype(k))
8034       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8035       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8036       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8037       call transpose2(EUgC(1,1,k),auxmat(1,1))
8038       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8039       vv1(1)=pizda1(1,1)-pizda1(2,2)
8040       vv1(2)=pizda1(1,2)+pizda1(2,1)
8041       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8042       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8043       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8044       s5=scalar2(vv(1),Dtobr2(1,i))
8045 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8046       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8047       if (calc_grad) then
8048       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8049      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8050      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8051      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8052      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8053      & +scalar2(vv(1),Dtobr2der(1,i)))
8054       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8055       vv1(1)=pizda1(1,1)-pizda1(2,2)
8056       vv1(2)=pizda1(1,2)+pizda1(2,1)
8057       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8058       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8059       if (l.eq.j+1) then
8060         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8061      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8062      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8063      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8064      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8065       else
8066         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8067      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8068      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8069      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8070      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8071       endif
8072       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8073       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8074       vv1(1)=pizda1(1,1)-pizda1(2,2)
8075       vv1(2)=pizda1(1,2)+pizda1(2,1)
8076       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8077      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8078      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8079      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8080       do iii=1,2
8081         if (swap) then
8082           ind=3-iii
8083         else
8084           ind=iii
8085         endif
8086         do kkk=1,5
8087           do lll=1,3
8088             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8089             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8090             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8091             call transpose2(EUgC(1,1,k),auxmat(1,1))
8092             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8093      &        pizda1(1,1))
8094             vv1(1)=pizda1(1,1)-pizda1(2,2)
8095             vv1(2)=pizda1(1,2)+pizda1(2,1)
8096             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8097             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8098      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8099             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8100      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8101             s5=scalar2(vv(1),Dtobr2(1,i))
8102             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8103           enddo
8104         enddo
8105       enddo
8106       endif ! calc_grad
8107       return
8108       end
8109 c----------------------------------------------------------------------------
8110       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8111       implicit real*8 (a-h,o-z)
8112       include 'DIMENSIONS'
8113       include 'COMMON.IOUNITS'
8114       include 'COMMON.CHAIN'
8115       include 'COMMON.DERIV'
8116       include 'COMMON.INTERACT'
8117       include 'COMMON.CONTACTS'
8118       include 'COMMON.CONTMAT'
8119       include 'COMMON.CORRMAT'
8120       include 'COMMON.TORSION'
8121       include 'COMMON.VAR'
8122       include 'COMMON.GEO'
8123       logical swap
8124       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8125      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8126       logical lprn
8127       common /kutas/ lprn
8128 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8129 C                                                                              C
8130 C      Parallel       Antiparallel                                             C
8131 C                                                                              C
8132 C          o             o                                                     C
8133 C     \   /l\           /j\   /                                                C
8134 C      \ /   \         /   \ /                                                 C
8135 C       o| o |         | o |o                                                  C
8136 C     \ j|/k\|      \  |/k\|l                                                  C
8137 C      \ /   \       \ /   \                                                   C
8138 C       o             o                                                        C
8139 C       i             i                                                        C
8140 C                                                                              C
8141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8142 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8143 C AL 7/4/01 s1 would occur in the sixth-order moment,
8144 C           but not in a cluster cumulant
8145 #ifdef MOMENT
8146       s1=dip(1,jj,i)*dip(1,kk,k)
8147 #endif
8148       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8149       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8150       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8151       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8152       call transpose2(EUg(1,1,k),auxmat(1,1))
8153       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8154       vv(1)=pizda(1,1)-pizda(2,2)
8155       vv(2)=pizda(1,2)+pizda(2,1)
8156       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8157 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8158 #ifdef MOMENT
8159       eello6_graph2=-(s1+s2+s3+s4)
8160 #else
8161       eello6_graph2=-(s2+s3+s4)
8162 #endif
8163 c      eello6_graph2=-s3
8164 C Derivatives in gamma(i-1)
8165       if (calc_grad) then
8166       if (i.gt.1) then
8167 #ifdef MOMENT
8168         s1=dipderg(1,jj,i)*dip(1,kk,k)
8169 #endif
8170         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8171         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8172         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8173         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8174 #ifdef MOMENT
8175         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8176 #else
8177         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8178 #endif
8179 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8180       endif
8181 C Derivatives in gamma(k-1)
8182 #ifdef MOMENT
8183       s1=dip(1,jj,i)*dipderg(1,kk,k)
8184 #endif
8185       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8186       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8187       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8188       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8189       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8190       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8191       vv(1)=pizda(1,1)-pizda(2,2)
8192       vv(2)=pizda(1,2)+pizda(2,1)
8193       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8194 #ifdef MOMENT
8195       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8196 #else
8197       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8198 #endif
8199 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8200 C Derivatives in gamma(j-1) or gamma(l-1)
8201       if (j.gt.1) then
8202 #ifdef MOMENT
8203         s1=dipderg(3,jj,i)*dip(1,kk,k)
8204 #endif
8205         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8206         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8207         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8208         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8209         vv(1)=pizda(1,1)-pizda(2,2)
8210         vv(2)=pizda(1,2)+pizda(2,1)
8211         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8212 #ifdef MOMENT
8213         if (swap) then
8214           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8215         else
8216           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8217         endif
8218 #endif
8219         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8220 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8221       endif
8222 C Derivatives in gamma(l-1) or gamma(j-1)
8223       if (l.gt.1) then
8224 #ifdef MOMENT
8225         s1=dip(1,jj,i)*dipderg(3,kk,k)
8226 #endif
8227         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8228         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8229         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8230         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8231         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8232         vv(1)=pizda(1,1)-pizda(2,2)
8233         vv(2)=pizda(1,2)+pizda(2,1)
8234         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8235 #ifdef MOMENT
8236         if (swap) then
8237           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8238         else
8239           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8240         endif
8241 #endif
8242         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8243 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8244       endif
8245 C Cartesian derivatives.
8246       if (lprn) then
8247         write (2,*) 'In eello6_graph2'
8248         do iii=1,2
8249           write (2,*) 'iii=',iii
8250           do kkk=1,5
8251             write (2,*) 'kkk=',kkk
8252             do jjj=1,2
8253               write (2,'(3(2f10.5),5x)')
8254      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8255             enddo
8256           enddo
8257         enddo
8258       endif
8259       do iii=1,2
8260         do kkk=1,5
8261           do lll=1,3
8262 #ifdef MOMENT
8263             if (iii.eq.1) then
8264               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8265             else
8266               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8267             endif
8268 #endif
8269             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8270      &        auxvec(1))
8271             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8272             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8273      &        auxvec(1))
8274             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8275             call transpose2(EUg(1,1,k),auxmat(1,1))
8276             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8277      &        pizda(1,1))
8278             vv(1)=pizda(1,1)-pizda(2,2)
8279             vv(2)=pizda(1,2)+pizda(2,1)
8280             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8281 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8282 #ifdef MOMENT
8283             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8284 #else
8285             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8286 #endif
8287             if (swap) then
8288               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8289             else
8290               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8291             endif
8292           enddo
8293         enddo
8294       enddo
8295       endif ! calc_grad
8296       return
8297       end
8298 c----------------------------------------------------------------------------
8299       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8300       implicit real*8 (a-h,o-z)
8301       include 'DIMENSIONS'
8302       include 'COMMON.IOUNITS'
8303       include 'COMMON.CHAIN'
8304       include 'COMMON.DERIV'
8305       include 'COMMON.INTERACT'
8306       include 'COMMON.CONTACTS'
8307       include 'COMMON.CONTMAT'
8308       include 'COMMON.CORRMAT'
8309       include 'COMMON.TORSION'
8310       include 'COMMON.VAR'
8311       include 'COMMON.GEO'
8312       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8313       logical swap
8314 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8315 C                                                                              C
8316 C      Parallel       Antiparallel                                             C
8317 C                                                                              C
8318 C          o             o                                                     C
8319 C         /l\   /   \   /j\                                                    C
8320 C        /   \ /     \ /   \                                                   C
8321 C       /| o |o       o| o |\                                                  C
8322 C       j|/k\|  /      |/k\|l /                                                C
8323 C        /   \ /       /   \ /                                                 C
8324 C       /     o       /     o                                                  C
8325 C       i             i                                                        C
8326 C                                                                              C
8327 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8328 C
8329 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8330 C           energy moment and not to the cluster cumulant.
8331       iti=itortyp(itype(i))
8332       if (j.lt.nres-1) then
8333         itj1=itype2loc(itype(j+1))
8334       else
8335         itj1=nloctyp
8336       endif
8337       itk=itype2loc(itype(k))
8338       itk1=itype2loc(itype(k+1))
8339       if (l.lt.nres-1) then
8340         itl1=itype2loc(itype(l+1))
8341       else
8342         itl1=nloctyp
8343       endif
8344 #ifdef MOMENT
8345       s1=dip(4,jj,i)*dip(4,kk,k)
8346 #endif
8347       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8348       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8349       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8350       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8351       call transpose2(EE(1,1,k),auxmat(1,1))
8352       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8353       vv(1)=pizda(1,1)+pizda(2,2)
8354       vv(2)=pizda(2,1)-pizda(1,2)
8355       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8356 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8357 cd     & "sum",-(s2+s3+s4)
8358 #ifdef MOMENT
8359       eello6_graph3=-(s1+s2+s3+s4)
8360 #else
8361       eello6_graph3=-(s2+s3+s4)
8362 #endif
8363 c      eello6_graph3=-s4
8364 C Derivatives in gamma(k-1)
8365       if (calc_grad) then
8366       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8367       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8368       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8369       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8370 C Derivatives in gamma(l-1)
8371       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8372       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8373       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8374       vv(1)=pizda(1,1)+pizda(2,2)
8375       vv(2)=pizda(2,1)-pizda(1,2)
8376       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8377       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8378 C Cartesian derivatives.
8379       do iii=1,2
8380         do kkk=1,5
8381           do lll=1,3
8382 #ifdef MOMENT
8383             if (iii.eq.1) then
8384               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8385             else
8386               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8387             endif
8388 #endif
8389             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8390      &        auxvec(1))
8391             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8392             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8393      &        auxvec(1))
8394             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8395             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8396      &        pizda(1,1))
8397             vv(1)=pizda(1,1)+pizda(2,2)
8398             vv(2)=pizda(2,1)-pizda(1,2)
8399             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8400 #ifdef MOMENT
8401             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8402 #else
8403             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8404 #endif
8405             if (swap) then
8406               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8407             else
8408               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8409             endif
8410 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8411           enddo
8412         enddo
8413       enddo
8414       endif ! calc_grad
8415       return
8416       end
8417 c----------------------------------------------------------------------------
8418       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8419       implicit real*8 (a-h,o-z)
8420       include 'DIMENSIONS'
8421       include 'COMMON.IOUNITS'
8422       include 'COMMON.CHAIN'
8423       include 'COMMON.DERIV'
8424       include 'COMMON.INTERACT'
8425       include 'COMMON.CONTACTS'
8426       include 'COMMON.CONTMAT'
8427       include 'COMMON.CORRMAT'
8428       include 'COMMON.TORSION'
8429       include 'COMMON.VAR'
8430       include 'COMMON.GEO'
8431       include 'COMMON.FFIELD'
8432       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8433      & auxvec1(2),auxmat1(2,2)
8434       logical swap
8435 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8436 C                                                                              C
8437 C      Parallel       Antiparallel                                             C
8438 C                                                                              C
8439 C          o             o                                                     C
8440 C         /l\   /   \   /j\                                                    C
8441 C        /   \ /     \ /   \                                                   C
8442 C       /| o |o       o| o |\                                                  C
8443 C     \ j|/k\|      \  |/k\|l                                                  C
8444 C      \ /   \       \ /   \                                                   C
8445 C       o     \       o     \                                                  C
8446 C       i             i                                                        C
8447 C                                                                              C
8448 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8449 C
8450 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8451 C           energy moment and not to the cluster cumulant.
8452 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8453       iti=itype2loc(itype(i))
8454       itj=itype2loc(itype(j))
8455       if (j.lt.nres-1) then
8456         itj1=itype2loc(itype(j+1))
8457       else
8458         itj1=nloctyp
8459       endif
8460       itk=itype2loc(itype(k))
8461       if (k.lt.nres-1) then
8462         itk1=itype2loc(itype(k+1))
8463       else
8464         itk1=nloctyp
8465       endif
8466       itl=itype2loc(itype(l))
8467       if (l.lt.nres-1) then
8468         itl1=itype2loc(itype(l+1))
8469       else
8470         itl1=nloctyp
8471       endif
8472 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8473 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8474 cd     & ' itl',itl,' itl1',itl1
8475 #ifdef MOMENT
8476       if (imat.eq.1) then
8477         s1=dip(3,jj,i)*dip(3,kk,k)
8478       else
8479         s1=dip(2,jj,j)*dip(2,kk,l)
8480       endif
8481 #endif
8482       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8483       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8484       if (j.eq.l+1) then
8485         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8486         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8487       else
8488         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8489         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8490       endif
8491       call transpose2(EUg(1,1,k),auxmat(1,1))
8492       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8493       vv(1)=pizda(1,1)-pizda(2,2)
8494       vv(2)=pizda(2,1)+pizda(1,2)
8495       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8496 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8497 #ifdef MOMENT
8498       eello6_graph4=-(s1+s2+s3+s4)
8499 #else
8500       eello6_graph4=-(s2+s3+s4)
8501 #endif
8502 C Derivatives in gamma(i-1)
8503       if (calc_grad) then
8504       if (i.gt.1) then
8505 #ifdef MOMENT
8506         if (imat.eq.1) then
8507           s1=dipderg(2,jj,i)*dip(3,kk,k)
8508         else
8509           s1=dipderg(4,jj,j)*dip(2,kk,l)
8510         endif
8511 #endif
8512         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8513         if (j.eq.l+1) then
8514           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8515           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8516         else
8517           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8518           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8519         endif
8520         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8521         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8522 cd          write (2,*) 'turn6 derivatives'
8523 #ifdef MOMENT
8524           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8525 #else
8526           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8527 #endif
8528         else
8529 #ifdef MOMENT
8530           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8531 #else
8532           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8533 #endif
8534         endif
8535       endif
8536 C Derivatives in gamma(k-1)
8537 #ifdef MOMENT
8538       if (imat.eq.1) then
8539         s1=dip(3,jj,i)*dipderg(2,kk,k)
8540       else
8541         s1=dip(2,jj,j)*dipderg(4,kk,l)
8542       endif
8543 #endif
8544       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8545       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8546       if (j.eq.l+1) then
8547         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8548         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8549       else
8550         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8551         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8552       endif
8553       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8554       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8555       vv(1)=pizda(1,1)-pizda(2,2)
8556       vv(2)=pizda(2,1)+pizda(1,2)
8557       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8558       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8559 #ifdef MOMENT
8560         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8561 #else
8562         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8563 #endif
8564       else
8565 #ifdef MOMENT
8566         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8567 #else
8568         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8569 #endif
8570       endif
8571 C Derivatives in gamma(j-1) or gamma(l-1)
8572       if (l.eq.j+1 .and. l.gt.1) then
8573         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8574         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8575         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8576         vv(1)=pizda(1,1)-pizda(2,2)
8577         vv(2)=pizda(2,1)+pizda(1,2)
8578         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8579         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8580       else if (j.gt.1) then
8581         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8582         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8583         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8584         vv(1)=pizda(1,1)-pizda(2,2)
8585         vv(2)=pizda(2,1)+pizda(1,2)
8586         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8587         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8588           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8589         else
8590           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8591         endif
8592       endif
8593 C Cartesian derivatives.
8594       do iii=1,2
8595         do kkk=1,5
8596           do lll=1,3
8597 #ifdef MOMENT
8598             if (iii.eq.1) then
8599               if (imat.eq.1) then
8600                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8601               else
8602                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8603               endif
8604             else
8605               if (imat.eq.1) then
8606                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8607               else
8608                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8609               endif
8610             endif
8611 #endif
8612             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8613      &        auxvec(1))
8614             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8615             if (j.eq.l+1) then
8616               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8617      &          b1(1,j+1),auxvec(1))
8618               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8619             else
8620               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8621      &          b1(1,l+1),auxvec(1))
8622               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8623             endif
8624             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8625      &        pizda(1,1))
8626             vv(1)=pizda(1,1)-pizda(2,2)
8627             vv(2)=pizda(2,1)+pizda(1,2)
8628             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8629             if (swap) then
8630               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8631 #ifdef MOMENT
8632                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8633      &             -(s1+s2+s4)
8634 #else
8635                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8636      &             -(s2+s4)
8637 #endif
8638                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8639               else
8640 #ifdef MOMENT
8641                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8642 #else
8643                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8644 #endif
8645                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8646               endif
8647             else
8648 #ifdef MOMENT
8649               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8650 #else
8651               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8652 #endif
8653               if (l.eq.j+1) then
8654                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8655               else
8656                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8657               endif
8658             endif
8659           enddo
8660         enddo
8661       enddo
8662       endif ! calc_grad
8663       return
8664       end
8665 c----------------------------------------------------------------------------
8666       double precision function eello_turn6(i,jj,kk)
8667       implicit real*8 (a-h,o-z)
8668       include 'DIMENSIONS'
8669       include 'COMMON.IOUNITS'
8670       include 'COMMON.CHAIN'
8671       include 'COMMON.DERIV'
8672       include 'COMMON.INTERACT'
8673       include 'COMMON.CONTACTS'
8674       include 'COMMON.CONTMAT'
8675       include 'COMMON.CORRMAT'
8676       include 'COMMON.TORSION'
8677       include 'COMMON.VAR'
8678       include 'COMMON.GEO'
8679       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8680      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8681      &  ggg1(3),ggg2(3)
8682       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8683      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8684 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8685 C           the respective energy moment and not to the cluster cumulant.
8686       s1=0.0d0
8687       s8=0.0d0
8688       s13=0.0d0
8689 c
8690       eello_turn6=0.0d0
8691       j=i+4
8692       k=i+1
8693       l=i+3
8694       iti=itype2loc(itype(i))
8695       itk=itype2loc(itype(k))
8696       itk1=itype2loc(itype(k+1))
8697       itl=itype2loc(itype(l))
8698       itj=itype2loc(itype(j))
8699 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8700 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8701 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8702 cd        eello6=0.0d0
8703 cd        return
8704 cd      endif
8705 cd      write (iout,*)
8706 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8707 cd     &   ' and',k,l
8708 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8709       do iii=1,2
8710         do kkk=1,5
8711           do lll=1,3
8712             derx_turn(lll,kkk,iii)=0.0d0
8713           enddo
8714         enddo
8715       enddo
8716 cd      eij=1.0d0
8717 cd      ekl=1.0d0
8718 cd      ekont=1.0d0
8719       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8720 cd      eello6_5=0.0d0
8721 cd      write (2,*) 'eello6_5',eello6_5
8722 #ifdef MOMENT
8723       call transpose2(AEA(1,1,1),auxmat(1,1))
8724       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8725       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8726       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8727 #endif
8728       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8729       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8730       s2 = scalar2(b1(1,k),vtemp1(1))
8731 #ifdef MOMENT
8732       call transpose2(AEA(1,1,2),atemp(1,1))
8733       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8734       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8735       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8736 #endif
8737       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8738       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8739       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8740 #ifdef MOMENT
8741       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8742       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8743       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8744       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8745       ss13 = scalar2(b1(1,k),vtemp4(1))
8746       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8747 #endif
8748 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8749 c      s1=0.0d0
8750 c      s2=0.0d0
8751 c      s8=0.0d0
8752 c      s12=0.0d0
8753 c      s13=0.0d0
8754       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8755 C Derivatives in gamma(i+2)
8756       if (calc_grad) then
8757       s1d =0.0d0
8758       s8d =0.0d0
8759 #ifdef MOMENT
8760       call transpose2(AEA(1,1,1),auxmatd(1,1))
8761       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8762       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8763       call transpose2(AEAderg(1,1,2),atempd(1,1))
8764       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8765       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8766 #endif
8767       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8768       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8769       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8770 c      s1d=0.0d0
8771 c      s2d=0.0d0
8772 c      s8d=0.0d0
8773 c      s12d=0.0d0
8774 c      s13d=0.0d0
8775       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8776 C Derivatives in gamma(i+3)
8777 #ifdef MOMENT
8778       call transpose2(AEA(1,1,1),auxmatd(1,1))
8779       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8780       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8781       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8782 #endif
8783       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8784       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8785       s2d = scalar2(b1(1,k),vtemp1d(1))
8786 #ifdef MOMENT
8787       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8788       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8789 #endif
8790       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8791 #ifdef MOMENT
8792       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8793       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8794       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8795 #endif
8796 c      s1d=0.0d0
8797 c      s2d=0.0d0
8798 c      s8d=0.0d0
8799 c      s12d=0.0d0
8800 c      s13d=0.0d0
8801 #ifdef MOMENT
8802       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8803      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8804 #else
8805       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8806      &               -0.5d0*ekont*(s2d+s12d)
8807 #endif
8808 C Derivatives in gamma(i+4)
8809       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8810       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8811       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8812 #ifdef MOMENT
8813       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8814       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8815       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8816 #endif
8817 c      s1d=0.0d0
8818 c      s2d=0.0d0
8819 c      s8d=0.0d0
8820 C      s12d=0.0d0
8821 c      s13d=0.0d0
8822 #ifdef MOMENT
8823       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8824 #else
8825       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8826 #endif
8827 C Derivatives in gamma(i+5)
8828 #ifdef MOMENT
8829       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8830       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8831       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8832 #endif
8833       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8834       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8835       s2d = scalar2(b1(1,k),vtemp1d(1))
8836 #ifdef MOMENT
8837       call transpose2(AEA(1,1,2),atempd(1,1))
8838       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8839       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8840 #endif
8841       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8842       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8843 #ifdef MOMENT
8844       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8845       ss13d = scalar2(b1(1,k),vtemp4d(1))
8846       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8847 #endif
8848 c      s1d=0.0d0
8849 c      s2d=0.0d0
8850 c      s8d=0.0d0
8851 c      s12d=0.0d0
8852 c      s13d=0.0d0
8853 #ifdef MOMENT
8854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8855      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8856 #else
8857       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8858      &               -0.5d0*ekont*(s2d+s12d)
8859 #endif
8860 C Cartesian derivatives
8861       do iii=1,2
8862         do kkk=1,5
8863           do lll=1,3
8864 #ifdef MOMENT
8865             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8866             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8867             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8868 #endif
8869             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8870             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8871      &          vtemp1d(1))
8872             s2d = scalar2(b1(1,k),vtemp1d(1))
8873 #ifdef MOMENT
8874             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8875             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8876             s8d = -(atempd(1,1)+atempd(2,2))*
8877      &           scalar2(cc(1,1,l),vtemp2(1))
8878 #endif
8879             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8880      &           auxmatd(1,1))
8881             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8882             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8883 c      s1d=0.0d0
8884 c      s2d=0.0d0
8885 c      s8d=0.0d0
8886 c      s12d=0.0d0
8887 c      s13d=0.0d0
8888 #ifdef MOMENT
8889             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8890      &        - 0.5d0*(s1d+s2d)
8891 #else
8892             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8893      &        - 0.5d0*s2d
8894 #endif
8895 #ifdef MOMENT
8896             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8897      &        - 0.5d0*(s8d+s12d)
8898 #else
8899             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8900      &        - 0.5d0*s12d
8901 #endif
8902           enddo
8903         enddo
8904       enddo
8905 #ifdef MOMENT
8906       do kkk=1,5
8907         do lll=1,3
8908           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8909      &      achuj_tempd(1,1))
8910           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8911           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8912           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8913           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8914           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8915      &      vtemp4d(1))
8916           ss13d = scalar2(b1(1,k),vtemp4d(1))
8917           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8918           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8919         enddo
8920       enddo
8921 #endif
8922 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8923 cd     &  16*eel_turn6_num
8924 cd      goto 1112
8925       if (j.lt.nres-1) then
8926         j1=j+1
8927         j2=j-1
8928       else
8929         j1=j-1
8930         j2=j-2
8931       endif
8932       if (l.lt.nres-1) then
8933         l1=l+1
8934         l2=l-1
8935       else
8936         l1=l-1
8937         l2=l-2
8938       endif
8939       do ll=1,3
8940 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8941 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8942 cgrad        ghalf=0.5d0*ggg1(ll)
8943 cd        ghalf=0.0d0
8944         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8945         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8946         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8947      &    +ekont*derx_turn(ll,2,1)
8948         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8949         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8950      &    +ekont*derx_turn(ll,4,1)
8951         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8952         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8953         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8954 cgrad        ghalf=0.5d0*ggg2(ll)
8955 cd        ghalf=0.0d0
8956         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8957      &    +ekont*derx_turn(ll,2,2)
8958         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8959         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8960      &    +ekont*derx_turn(ll,4,2)
8961         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8962         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8963         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8964       enddo
8965 cd      goto 1112
8966 cgrad      do m=i+1,j-1
8967 cgrad        do ll=1,3
8968 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8969 cgrad        enddo
8970 cgrad      enddo
8971 cgrad      do m=k+1,l-1
8972 cgrad        do ll=1,3
8973 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8974 cgrad        enddo
8975 cgrad      enddo
8976 cgrad1112  continue
8977 cgrad      do m=i+2,j2
8978 cgrad        do ll=1,3
8979 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8980 cgrad        enddo
8981 cgrad      enddo
8982 cgrad      do m=k+2,l2
8983 cgrad        do ll=1,3
8984 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8985 cgrad        enddo
8986 cgrad      enddo
8987 cd      do iii=1,nres-3
8988 cd        write (2,*) iii,g_corr6_loc(iii)
8989 cd      enddo
8990       endif ! calc_grad
8991       eello_turn6=ekont*eel_turn6
8992 cd      write (2,*) 'ekont',ekont
8993 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8994       return
8995       end
8996 #endif
8997 crc-------------------------------------------------
8998 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8999       subroutine Eliptransfer(eliptran)
9000       implicit real*8 (a-h,o-z)
9001       include 'DIMENSIONS'
9002       include 'COMMON.GEO'
9003       include 'COMMON.VAR'
9004       include 'COMMON.LOCAL'
9005       include 'COMMON.CHAIN'
9006       include 'COMMON.DERIV'
9007       include 'COMMON.INTERACT'
9008       include 'COMMON.IOUNITS'
9009       include 'COMMON.CALC'
9010       include 'COMMON.CONTROL'
9011       include 'COMMON.SPLITELE'
9012       include 'COMMON.SBRIDGE'
9013 C this is done by Adasko
9014 C      print *,"wchodze"
9015 C structure of box:
9016 C      water
9017 C--bordliptop-- buffore starts
9018 C--bufliptop--- here true lipid starts
9019 C      lipid
9020 C--buflipbot--- lipid ends buffore starts
9021 C--bordlipbot--buffore ends
9022       eliptran=0.0
9023       do i=1,nres
9024 C       do i=1,1
9025         if (itype(i).eq.ntyp1) cycle
9026
9027         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9028         if (positi.le.0) positi=positi+boxzsize
9029 C        print *,i
9030 C first for peptide groups
9031 c for each residue check if it is in lipid or lipid water border area
9032        if ((positi.gt.bordlipbot)
9033      &.and.(positi.lt.bordliptop)) then
9034 C the energy transfer exist
9035         if (positi.lt.buflipbot) then
9036 C what fraction I am in
9037          fracinbuf=1.0d0-
9038      &        ((positi-bordlipbot)/lipbufthick)
9039 C lipbufthick is thickenes of lipid buffore
9040          sslip=sscalelip(fracinbuf)
9041          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9042          eliptran=eliptran+sslip*pepliptran
9043          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9044          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9045 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9046         elseif (positi.gt.bufliptop) then
9047          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9048          sslip=sscalelip(fracinbuf)
9049          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9050          eliptran=eliptran+sslip*pepliptran
9051          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9052          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9053 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9054 C          print *, "doing sscalefor top part"
9055 C         print *,i,sslip,fracinbuf,ssgradlip
9056         else
9057          eliptran=eliptran+pepliptran
9058 C         print *,"I am in true lipid"
9059         endif
9060 C       else
9061 C       eliptran=elpitran+0.0 ! I am in water
9062        endif
9063        enddo
9064 C       print *, "nic nie bylo w lipidzie?"
9065 C now multiply all by the peptide group transfer factor
9066 C       eliptran=eliptran*pepliptran
9067 C now the same for side chains
9068 CV       do i=1,1
9069        do i=1,nres
9070         if (itype(i).eq.ntyp1) cycle
9071         positi=(mod(c(3,i+nres),boxzsize))
9072         if (positi.le.0) positi=positi+boxzsize
9073 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9074 c for each residue check if it is in lipid or lipid water border area
9075 C       respos=mod(c(3,i+nres),boxzsize)
9076 C       print *,positi,bordlipbot,buflipbot
9077        if ((positi.gt.bordlipbot)
9078      & .and.(positi.lt.bordliptop)) then
9079 C the energy transfer exist
9080         if (positi.lt.buflipbot) then
9081          fracinbuf=1.0d0-
9082      &     ((positi-bordlipbot)/lipbufthick)
9083 C lipbufthick is thickenes of lipid buffore
9084          sslip=sscalelip(fracinbuf)
9085          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9086          eliptran=eliptran+sslip*liptranene(itype(i))
9087          gliptranx(3,i)=gliptranx(3,i)
9088      &+ssgradlip*liptranene(itype(i))
9089          gliptranc(3,i-1)= gliptranc(3,i-1)
9090      &+ssgradlip*liptranene(itype(i))
9091 C         print *,"doing sccale for lower part"
9092         elseif (positi.gt.bufliptop) then
9093          fracinbuf=1.0d0-
9094      &((bordliptop-positi)/lipbufthick)
9095          sslip=sscalelip(fracinbuf)
9096          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9097          eliptran=eliptran+sslip*liptranene(itype(i))
9098          gliptranx(3,i)=gliptranx(3,i)
9099      &+ssgradlip*liptranene(itype(i))
9100          gliptranc(3,i-1)= gliptranc(3,i-1)
9101      &+ssgradlip*liptranene(itype(i))
9102 C          print *, "doing sscalefor top part",sslip,fracinbuf
9103         else
9104          eliptran=eliptran+liptranene(itype(i))
9105 C         print *,"I am in true lipid"
9106         endif
9107         endif ! if in lipid or buffor
9108 C       else
9109 C       eliptran=elpitran+0.0 ! I am in water
9110        enddo
9111        return
9112        end
9113
9114
9115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9116
9117       SUBROUTINE MATVEC2(A1,V1,V2)
9118       implicit real*8 (a-h,o-z)
9119       include 'DIMENSIONS'
9120       DIMENSION A1(2,2),V1(2),V2(2)
9121 c      DO 1 I=1,2
9122 c        VI=0.0
9123 c        DO 3 K=1,2
9124 c    3     VI=VI+A1(I,K)*V1(K)
9125 c        Vaux(I)=VI
9126 c    1 CONTINUE
9127
9128       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9129       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9130
9131       v2(1)=vaux1
9132       v2(2)=vaux2
9133       END
9134 C---------------------------------------
9135       SUBROUTINE MATMAT2(A1,A2,A3)
9136       implicit real*8 (a-h,o-z)
9137       include 'DIMENSIONS'
9138       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9139 c      DIMENSION AI3(2,2)
9140 c        DO  J=1,2
9141 c          A3IJ=0.0
9142 c          DO K=1,2
9143 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9144 c          enddo
9145 c          A3(I,J)=A3IJ
9146 c       enddo
9147 c      enddo
9148
9149       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9150       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9151       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9152       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9153
9154       A3(1,1)=AI3_11
9155       A3(2,1)=AI3_21
9156       A3(1,2)=AI3_12
9157       A3(2,2)=AI3_22
9158       END
9159
9160 c-------------------------------------------------------------------------
9161       double precision function scalar2(u,v)
9162       implicit none
9163       double precision u(2),v(2)
9164       double precision sc
9165       integer i
9166       scalar2=u(1)*v(1)+u(2)*v(2)
9167       return
9168       end
9169
9170 C-----------------------------------------------------------------------------
9171
9172       subroutine transpose2(a,at)
9173       implicit none
9174       double precision a(2,2),at(2,2)
9175       at(1,1)=a(1,1)
9176       at(1,2)=a(2,1)
9177       at(2,1)=a(1,2)
9178       at(2,2)=a(2,2)
9179       return
9180       end
9181 c--------------------------------------------------------------------------
9182       subroutine transpose(n,a,at)
9183       implicit none
9184       integer n,i,j
9185       double precision a(n,n),at(n,n)
9186       do i=1,n
9187         do j=1,n
9188           at(j,i)=a(i,j)
9189         enddo
9190       enddo
9191       return
9192       end
9193 C---------------------------------------------------------------------------
9194       subroutine prodmat3(a1,a2,kk,transp,prod)
9195       implicit none
9196       integer i,j
9197       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9198       logical transp
9199 crc      double precision auxmat(2,2),prod_(2,2)
9200
9201       if (transp) then
9202 crc        call transpose2(kk(1,1),auxmat(1,1))
9203 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9204 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9205
9206            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9207      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9208            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9209      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9210            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9211      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9212            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9213      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9214
9215       else
9216 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9217 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9218
9219            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9220      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9221            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9222      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9223            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9224      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9225            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9226      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9227
9228       endif
9229 c      call transpose2(a2(1,1),a2t(1,1))
9230
9231 crc      print *,transp
9232 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9233 crc      print *,((prod(i,j),i=1,2),j=1,2)
9234
9235       return
9236       end
9237 C-----------------------------------------------------------------------------
9238       double precision function scalar(u,v)
9239       implicit none
9240       double precision u(3),v(3)
9241       double precision sc
9242       integer i
9243       sc=0.0d0
9244       do i=1,3
9245         sc=sc+u(i)*v(i)
9246       enddo
9247       scalar=sc
9248       return
9249       end
9250 C-----------------------------------------------------------------------
9251       double precision function sscale(r)
9252       double precision r,gamm
9253       include "COMMON.SPLITELE"
9254       if(r.lt.r_cut-rlamb) then
9255         sscale=1.0d0
9256       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9257         gamm=(r-(r_cut-rlamb))/rlamb
9258         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9259       else
9260         sscale=0d0
9261       endif
9262       return
9263       end
9264 C-----------------------------------------------------------------------
9265 C-----------------------------------------------------------------------
9266       double precision function sscagrad(r)
9267       double precision r,gamm
9268       include "COMMON.SPLITELE"
9269       if(r.lt.r_cut-rlamb) then
9270         sscagrad=0.0d0
9271       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9272         gamm=(r-(r_cut-rlamb))/rlamb
9273         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9274       else
9275         sscagrad=0.0d0
9276       endif
9277       return
9278       end
9279 C-----------------------------------------------------------------------
9280 C-----------------------------------------------------------------------
9281       double precision function sscalelip(r)
9282       double precision r,gamm
9283       include "COMMON.SPLITELE"
9284 C      if(r.lt.r_cut-rlamb) then
9285 C        sscale=1.0d0
9286 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9287 C        gamm=(r-(r_cut-rlamb))/rlamb
9288         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9289 C      else
9290 C        sscale=0d0
9291 C      endif
9292       return
9293       end
9294 C-----------------------------------------------------------------------
9295       double precision function sscagradlip(r)
9296       double precision r,gamm
9297       include "COMMON.SPLITELE"
9298 C     if(r.lt.r_cut-rlamb) then
9299 C        sscagrad=0.0d0
9300 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9301 C        gamm=(r-(r_cut-rlamb))/rlamb
9302         sscagradlip=r*(6*r-6.0d0)
9303 C      else
9304 C        sscagrad=0.0d0
9305 C      endif
9306       return
9307       end
9308
9309 C-----------------------------------------------------------------------
9310        subroutine set_shield_fac
9311       implicit real*8 (a-h,o-z)
9312       include 'DIMENSIONS'
9313       include 'COMMON.CHAIN'
9314       include 'COMMON.DERIV'
9315       include 'COMMON.IOUNITS'
9316       include 'COMMON.SHIELD'
9317       include 'COMMON.INTERACT'
9318 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9319       double precision div77_81/0.974996043d0/,
9320      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9321
9322 C the vector between center of side_chain and peptide group
9323        double precision pep_side(3),long,side_calf(3),
9324      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9325      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9326 C the line belowe needs to be changed for FGPROC>1
9327       do i=1,nres-1
9328       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9329       ishield_list(i)=0
9330 Cif there two consequtive dummy atoms there is no peptide group between them
9331 C the line below has to be changed for FGPROC>1
9332       VolumeTotal=0.0
9333       do k=1,nres
9334        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9335        dist_pep_side=0.0
9336        dist_side_calf=0.0
9337        do j=1,3
9338 C first lets set vector conecting the ithe side-chain with kth side-chain
9339       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9340 C      pep_side(j)=2.0d0
9341 C and vector conecting the side-chain with its proper calfa
9342       side_calf(j)=c(j,k+nres)-c(j,k)
9343 C      side_calf(j)=2.0d0
9344       pept_group(j)=c(j,i)-c(j,i+1)
9345 C lets have their lenght
9346       dist_pep_side=pep_side(j)**2+dist_pep_side
9347       dist_side_calf=dist_side_calf+side_calf(j)**2
9348       dist_pept_group=dist_pept_group+pept_group(j)**2
9349       enddo
9350        dist_pep_side=dsqrt(dist_pep_side)
9351        dist_pept_group=dsqrt(dist_pept_group)
9352        dist_side_calf=dsqrt(dist_side_calf)
9353       do j=1,3
9354         pep_side_norm(j)=pep_side(j)/dist_pep_side
9355         side_calf_norm(j)=dist_side_calf
9356       enddo
9357 C now sscale fraction
9358        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9359 C       print *,buff_shield,"buff"
9360 C now sscale
9361         if (sh_frac_dist.le.0.0) cycle
9362 C If we reach here it means that this side chain reaches the shielding sphere
9363 C Lets add him to the list for gradient
9364         ishield_list(i)=ishield_list(i)+1
9365 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9366 C this list is essential otherwise problem would be O3
9367         shield_list(ishield_list(i),i)=k
9368 C Lets have the sscale value
9369         if (sh_frac_dist.gt.1.0) then
9370          scale_fac_dist=1.0d0
9371          do j=1,3
9372          sh_frac_dist_grad(j)=0.0d0
9373          enddo
9374         else
9375          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9376      &                   *(2.0*sh_frac_dist-3.0d0)
9377          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9378      &                  /dist_pep_side/buff_shield*0.5
9379 C remember for the final gradient multiply sh_frac_dist_grad(j)
9380 C for side_chain by factor -2 !
9381          do j=1,3
9382          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9383 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9384 C     &                    sh_frac_dist_grad(j)
9385          enddo
9386         endif
9387 C        if ((i.eq.3).and.(k.eq.2)) then
9388 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9389 C     & ,"TU"
9390 C        endif
9391
9392 C this is what is now we have the distance scaling now volume...
9393       short=short_r_sidechain(itype(k))
9394       long=long_r_sidechain(itype(k))
9395       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9396 C now costhet_grad
9397 C       costhet=0.0d0
9398        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9399 C       costhet_fac=0.0d0
9400        do j=1,3
9401          costhet_grad(j)=costhet_fac*pep_side(j)
9402        enddo
9403 C remember for the final gradient multiply costhet_grad(j)
9404 C for side_chain by factor -2 !
9405 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9406 C pep_side0pept_group is vector multiplication
9407       pep_side0pept_group=0.0
9408       do j=1,3
9409       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9410       enddo
9411       cosalfa=(pep_side0pept_group/
9412      & (dist_pep_side*dist_side_calf))
9413       fac_alfa_sin=1.0-cosalfa**2
9414       fac_alfa_sin=dsqrt(fac_alfa_sin)
9415       rkprim=fac_alfa_sin*(long-short)+short
9416 C now costhet_grad
9417        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9418        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9419
9420        do j=1,3
9421          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9422      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9423      &*(long-short)/fac_alfa_sin*cosalfa/
9424      &((dist_pep_side*dist_side_calf))*
9425      &((side_calf(j))-cosalfa*
9426      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9427
9428         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9429      &*(long-short)/fac_alfa_sin*cosalfa
9430      &/((dist_pep_side*dist_side_calf))*
9431      &(pep_side(j)-
9432      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9433        enddo
9434
9435       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9436      &                    /VSolvSphere_div
9437      &                    *wshield
9438 C now the gradient...
9439 C grad_shield is gradient of Calfa for peptide groups
9440 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9441 C     &               costhet,cosphi
9442 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9443 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9444       do j=1,3
9445       grad_shield(j,i)=grad_shield(j,i)
9446 C gradient po skalowaniu
9447      &                +(sh_frac_dist_grad(j)
9448 C  gradient po costhet
9449      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9450      &-scale_fac_dist*(cosphi_grad_long(j))
9451      &/(1.0-cosphi) )*div77_81
9452      &*VofOverlap
9453 C grad_shield_side is Cbeta sidechain gradient
9454       grad_shield_side(j,ishield_list(i),i)=
9455      &        (sh_frac_dist_grad(j)*(-2.0d0)
9456      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9457      &       +scale_fac_dist*(cosphi_grad_long(j))
9458      &        *2.0d0/(1.0-cosphi))
9459      &        *div77_81*VofOverlap
9460
9461        grad_shield_loc(j,ishield_list(i),i)=
9462      &   scale_fac_dist*cosphi_grad_loc(j)
9463      &        *2.0d0/(1.0-cosphi)
9464      &        *div77_81*VofOverlap
9465       enddo
9466       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9467       enddo
9468       fac_shield(i)=VolumeTotal*div77_81+div4_81
9469 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9470       enddo
9471       return
9472       end
9473 C--------------------------------------------------------------------------
9474 C first for shielding is setting of function of side-chains
9475        subroutine set_shield_fac2
9476       implicit real*8 (a-h,o-z)
9477       include 'DIMENSIONS'
9478       include 'COMMON.CHAIN'
9479       include 'COMMON.DERIV'
9480       include 'COMMON.IOUNITS'
9481       include 'COMMON.SHIELD'
9482       include 'COMMON.INTERACT'
9483 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9484       double precision div77_81/0.974996043d0/,
9485      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9486
9487 C the vector between center of side_chain and peptide group
9488        double precision pep_side(3),long,side_calf(3),
9489      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9490      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9491 C the line belowe needs to be changed for FGPROC>1
9492       do i=1,nres-1
9493       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9494       ishield_list(i)=0
9495 Cif there two consequtive dummy atoms there is no peptide group between them
9496 C the line below has to be changed for FGPROC>1
9497       VolumeTotal=0.0
9498       do k=1,nres
9499        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9500        dist_pep_side=0.0
9501        dist_side_calf=0.0
9502        do j=1,3
9503 C first lets set vector conecting the ithe side-chain with kth side-chain
9504       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9505 C      pep_side(j)=2.0d0
9506 C and vector conecting the side-chain with its proper calfa
9507       side_calf(j)=c(j,k+nres)-c(j,k)
9508 C      side_calf(j)=2.0d0
9509       pept_group(j)=c(j,i)-c(j,i+1)
9510 C lets have their lenght
9511       dist_pep_side=pep_side(j)**2+dist_pep_side
9512       dist_side_calf=dist_side_calf+side_calf(j)**2
9513       dist_pept_group=dist_pept_group+pept_group(j)**2
9514       enddo
9515        dist_pep_side=dsqrt(dist_pep_side)
9516        dist_pept_group=dsqrt(dist_pept_group)
9517        dist_side_calf=dsqrt(dist_side_calf)
9518       do j=1,3
9519         pep_side_norm(j)=pep_side(j)/dist_pep_side
9520         side_calf_norm(j)=dist_side_calf
9521       enddo
9522 C now sscale fraction
9523        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9524 C       print *,buff_shield,"buff"
9525 C now sscale
9526         if (sh_frac_dist.le.0.0) cycle
9527 C If we reach here it means that this side chain reaches the shielding sphere
9528 C Lets add him to the list for gradient
9529         ishield_list(i)=ishield_list(i)+1
9530 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9531 C this list is essential otherwise problem would be O3
9532         shield_list(ishield_list(i),i)=k
9533 C Lets have the sscale value
9534         if (sh_frac_dist.gt.1.0) then
9535          scale_fac_dist=1.0d0
9536          do j=1,3
9537          sh_frac_dist_grad(j)=0.0d0
9538          enddo
9539         else
9540          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9541      &                   *(2.0d0*sh_frac_dist-3.0d0)
9542          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9543      &                  /dist_pep_side/buff_shield*0.5d0
9544 C remember for the final gradient multiply sh_frac_dist_grad(j)
9545 C for side_chain by factor -2 !
9546          do j=1,3
9547          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9548 C         sh_frac_dist_grad(j)=0.0d0
9549 C         scale_fac_dist=1.0d0
9550 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9551 C     &                    sh_frac_dist_grad(j)
9552          enddo
9553         endif
9554 C this is what is now we have the distance scaling now volume...
9555       short=short_r_sidechain(itype(k))
9556       long=long_r_sidechain(itype(k))
9557       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9558       sinthet=short/dist_pep_side*costhet
9559 C now costhet_grad
9560 C       costhet=0.6d0
9561 C       sinthet=0.8
9562        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9563 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9564 C     &             -short/dist_pep_side**2/costhet)
9565 C       costhet_fac=0.0d0
9566        do j=1,3
9567          costhet_grad(j)=costhet_fac*pep_side(j)
9568        enddo
9569 C remember for the final gradient multiply costhet_grad(j)
9570 C for side_chain by factor -2 !
9571 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9572 C pep_side0pept_group is vector multiplication
9573       pep_side0pept_group=0.0d0
9574       do j=1,3
9575       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9576       enddo
9577       cosalfa=(pep_side0pept_group/
9578      & (dist_pep_side*dist_side_calf))
9579       fac_alfa_sin=1.0d0-cosalfa**2
9580       fac_alfa_sin=dsqrt(fac_alfa_sin)
9581       rkprim=fac_alfa_sin*(long-short)+short
9582 C      rkprim=short
9583
9584 C now costhet_grad
9585        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9586 C       cosphi=0.6
9587        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9588        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9589      &      dist_pep_side**2)
9590 C       sinphi=0.8
9591        do j=1,3
9592          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9593      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9594      &*(long-short)/fac_alfa_sin*cosalfa/
9595      &((dist_pep_side*dist_side_calf))*
9596      &((side_calf(j))-cosalfa*
9597      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9598 C       cosphi_grad_long(j)=0.0d0
9599         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9600      &*(long-short)/fac_alfa_sin*cosalfa
9601      &/((dist_pep_side*dist_side_calf))*
9602      &(pep_side(j)-
9603      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9604 C       cosphi_grad_loc(j)=0.0d0
9605        enddo
9606 C      print *,sinphi,sinthet
9607       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9608      &                    /VSolvSphere_div
9609 C     &                    *wshield
9610 C now the gradient...
9611       do j=1,3
9612       grad_shield(j,i)=grad_shield(j,i)
9613 C gradient po skalowaniu
9614      &                +(sh_frac_dist_grad(j)*VofOverlap
9615 C  gradient po costhet
9616      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9617      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9618      &       sinphi/sinthet*costhet*costhet_grad(j)
9619      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9620      & )*wshield
9621 C grad_shield_side is Cbeta sidechain gradient
9622       grad_shield_side(j,ishield_list(i),i)=
9623      &        (sh_frac_dist_grad(j)*(-2.0d0)
9624      &        *VofOverlap
9625      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9626      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9627      &       sinphi/sinthet*costhet*costhet_grad(j)
9628      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9629      &       )*wshield
9630
9631        grad_shield_loc(j,ishield_list(i),i)=
9632      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9633      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9634      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9635      &        ))
9636      &        *wshield
9637       enddo
9638       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9639       enddo
9640       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9641 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9642 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9643       enddo
9644       return
9645       end
9646 C--------------------------------------------------------------------------
9647       double precision function tschebyshev(m,n,x,y)
9648       implicit none
9649       include "DIMENSIONS"
9650       integer i,m,n
9651       double precision x(n),y,yy(0:maxvar),aux
9652 c Tschebyshev polynomial. Note that the first term is omitted
9653 c m=0: the constant term is included
9654 c m=1: the constant term is not included
9655       yy(0)=1.0d0
9656       yy(1)=y
9657       do i=2,n
9658         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9659       enddo
9660       aux=0.0d0
9661       do i=m,n
9662         aux=aux+x(i)*yy(i)
9663       enddo
9664       tschebyshev=aux
9665       return
9666       end
9667 C--------------------------------------------------------------------------
9668       double precision function gradtschebyshev(m,n,x,y)
9669       implicit none
9670       include "DIMENSIONS"
9671       integer i,m,n
9672       double precision x(n+1),y,yy(0:maxvar),aux
9673 c Tschebyshev polynomial. Note that the first term is omitted
9674 c m=0: the constant term is included
9675 c m=1: the constant term is not included
9676       yy(0)=1.0d0
9677       yy(1)=2.0d0*y
9678       do i=2,n
9679         yy(i)=2*y*yy(i-1)-yy(i-2)
9680       enddo
9681       aux=0.0d0
9682       do i=m,n
9683         aux=aux+x(i+1)*yy(i)*(i+1)
9684 C        print *, x(i+1),yy(i),i
9685       enddo
9686       gradtschebyshev=aux
9687       return
9688       end
9689 c----------------------------------------------------------------------------
9690       double precision function sscale2(r,r_cut,r0,rlamb)
9691       implicit none
9692       double precision r,gamm,r_cut,r0,rlamb,rr
9693       rr = dabs(r-r0)
9694 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9695 c      write (2,*) "rr",rr
9696       if(rr.lt.r_cut-rlamb) then
9697         sscale2=1.0d0
9698       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9699         gamm=(rr-(r_cut-rlamb))/rlamb
9700         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9701       else
9702         sscale2=0d0
9703       endif
9704       return
9705       end
9706 C-----------------------------------------------------------------------
9707       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9708       implicit none
9709       double precision r,gamm,r_cut,r0,rlamb,rr
9710       rr = dabs(r-r0)
9711       if(rr.lt.r_cut-rlamb) then
9712         sscalgrad2=0.0d0
9713       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9714         gamm=(rr-(r_cut-rlamb))/rlamb
9715         if (r.ge.r0) then
9716           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9717         else
9718           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9719         endif
9720       else
9721         sscalgrad2=0.0d0
9722       endif
9723       return
9724       end
9725 c----------------------------------------------------------------------------
9726       subroutine e_saxs(Esaxs_constr)
9727       implicit none
9728       include 'DIMENSIONS'
9729 #ifdef MPI
9730       include "mpif.h"
9731       include "COMMON.SETUP"
9732       integer IERR
9733 #endif
9734       include 'COMMON.SBRIDGE'
9735       include 'COMMON.CHAIN'
9736       include 'COMMON.GEO'
9737       include 'COMMON.LOCAL'
9738       include 'COMMON.INTERACT'
9739       include 'COMMON.VAR'
9740       include 'COMMON.IOUNITS'
9741       include 'COMMON.DERIV'
9742       include 'COMMON.CONTROL'
9743       include 'COMMON.NAMES'
9744       include 'COMMON.FFIELD'
9745       include 'COMMON.LANGEVIN'
9746       include 'COMMON.SAXS'
9747 c
9748       double precision Esaxs_constr
9749       integer i,iint,j,k,l
9750       double precision PgradC(maxSAXS,3,maxres),
9751      &  PgradX(maxSAXS,3,maxres)
9752 #ifdef MPI
9753       double precision PgradC_(maxSAXS,3,maxres),
9754      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9755 #endif
9756       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9757      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9758      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9759      & auxX,auxX1,CACAgrad,Cnorm
9760       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9761       double precision dist
9762       external dist
9763 c  SAXS restraint penalty function
9764 #ifdef DEBUG
9765       write(iout,*) "------- SAXS penalty function start -------"
9766       write (iout,*) "nsaxs",nsaxs
9767       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9768       write (iout,*) "Psaxs"
9769       do i=1,nsaxs
9770         write (iout,'(i5,e15.5)') i, Psaxs(i)
9771       enddo
9772 #endif
9773       Esaxs_constr = 0.0d0
9774       do k=1,nsaxs
9775         Pcalc(k)=0.0d0
9776         do j=1,nres
9777           do l=1,3
9778             PgradC(k,l,j)=0.0d0
9779             PgradX(k,l,j)=0.0d0
9780           enddo
9781         enddo
9782       enddo
9783       do i=iatsc_s,iatsc_e
9784        if (itype(i).eq.ntyp1) cycle
9785        do iint=1,nint_gr(i)
9786          do j=istart(i,iint),iend(i,iint)
9787            if (itype(j).eq.ntyp1) cycle
9788 #ifdef ALLSAXS
9789            dijCACA=dist(i,j)
9790            dijCASC=dist(i,j+nres)
9791            dijSCCA=dist(i+nres,j)
9792            dijSCSC=dist(i+nres,j+nres)
9793            sigma2CACA=2.0d0/(pstok**2)
9794            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9795            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9796            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9797            do k=1,nsaxs
9798              dk = distsaxs(k)
9799              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9800              if (itype(j).ne.10) then
9801              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9802              else
9803              endif
9804              expCASC = 0.0d0
9805              if (itype(i).ne.10) then
9806              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9807              else
9808              expSCCA = 0.0d0
9809              endif
9810              if (itype(i).ne.10 .and. itype(j).ne.10) then
9811              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9812              else
9813              expSCSC = 0.0d0
9814              endif
9815              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9816 #ifdef DEBUG
9817              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9818 #endif
9819              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9820              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9821              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9822              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9823              do l=1,3
9824 c CA CA
9825                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9826                PgradC(k,l,i) = PgradC(k,l,i)-aux
9827                PgradC(k,l,j) = PgradC(k,l,j)+aux
9828 c CA SC
9829                if (itype(j).ne.10) then
9830                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9831                PgradC(k,l,i) = PgradC(k,l,i)-aux
9832                PgradC(k,l,j) = PgradC(k,l,j)+aux
9833                PgradX(k,l,j) = PgradX(k,l,j)+aux
9834                endif
9835 c SC CA
9836                if (itype(i).ne.10) then
9837                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9838                PgradX(k,l,i) = PgradX(k,l,i)-aux
9839                PgradC(k,l,i) = PgradC(k,l,i)-aux
9840                PgradC(k,l,j) = PgradC(k,l,j)+aux
9841                endif
9842 c SC SC
9843                if (itype(i).ne.10 .and. itype(j).ne.10) then
9844                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9845                PgradC(k,l,i) = PgradC(k,l,i)-aux
9846                PgradC(k,l,j) = PgradC(k,l,j)+aux
9847                PgradX(k,l,i) = PgradX(k,l,i)-aux
9848                PgradX(k,l,j) = PgradX(k,l,j)+aux
9849                endif
9850              enddo ! l
9851            enddo ! k
9852 #else
9853            dijCACA=dist(i,j)
9854            sigma2CACA=scal_rad**2*0.25d0/
9855      &        (restok(itype(j))**2+restok(itype(i))**2)
9856
9857            IF (saxs_cutoff.eq.0) THEN
9858            do k=1,nsaxs
9859              dk = distsaxs(k)
9860              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9861              Pcalc(k) = Pcalc(k)+expCACA
9862              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9863              do l=1,3
9864                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9865                PgradC(k,l,i) = PgradC(k,l,i)-aux
9866                PgradC(k,l,j) = PgradC(k,l,j)+aux
9867              enddo ! l
9868            enddo ! k
9869            ELSE
9870            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9871            do k=1,nsaxs
9872              dk = distsaxs(k)
9873 c             write (2,*) "ijk",i,j,k
9874              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9875              if (sss2.eq.0.0d0) cycle
9876              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9877              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9878              Pcalc(k) = Pcalc(k)+expCACA
9879 #ifdef DEBUG
9880              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9881 #endif
9882              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9883      &             ssgrad2*expCACA/sss2
9884              do l=1,3
9885 c CA CA
9886                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9887                PgradC(k,l,i) = PgradC(k,l,i)+aux
9888                PgradC(k,l,j) = PgradC(k,l,j)-aux
9889              enddo ! l
9890            enddo ! k
9891            ENDIF
9892 #endif
9893          enddo ! j
9894        enddo ! iint
9895       enddo ! i
9896 #ifdef MPI
9897       if (nfgtasks.gt.1) then
9898         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9899      &    MPI_SUM,king,FG_COMM,IERR)
9900         if (fg_rank.eq.king) then
9901           do k=1,nsaxs
9902             Pcalc(k) = Pcalc_(k)
9903           enddo
9904         endif
9905         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9906      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9907         if (fg_rank.eq.king) then
9908           do i=1,nres
9909             do l=1,3
9910               do k=1,nsaxs
9911                 PgradC(k,l,i) = PgradC_(k,l,i)
9912               enddo
9913             enddo
9914           enddo
9915         endif
9916 #ifdef ALLSAXS
9917         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9918      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9919         if (fg_rank.eq.king) then
9920           do i=1,nres
9921             do l=1,3
9922               do k=1,nsaxs
9923                 PgradX(k,l,i) = PgradX_(k,l,i)
9924               enddo
9925             enddo
9926           enddo
9927         endif
9928 #endif
9929       endif
9930 #endif
9931 #ifdef MPI
9932       if (fg_rank.eq.king) then
9933 #endif
9934       Cnorm = 0.0d0
9935       do k=1,nsaxs
9936         Cnorm = Cnorm + Pcalc(k)
9937       enddo
9938       Esaxs_constr = dlog(Cnorm)-wsaxs0
9939       do k=1,nsaxs
9940         if (Pcalc(k).gt.0.0d0)
9941      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9942 #ifdef DEBUG
9943         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9944 #endif
9945       enddo
9946 #ifdef DEBUG
9947       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9948 #endif
9949       do i=nnt,nct
9950         do l=1,3
9951           auxC=0.0d0
9952           auxC1=0.0d0
9953           auxX=0.0d0
9954           auxX1=0.d0
9955           do k=1,nsaxs
9956             if (Pcalc(k).gt.0)
9957      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9958             auxC1 = auxC1+PgradC(k,l,i)
9959 #ifdef ALLSAXS
9960             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9961             auxX1 = auxX1+PgradX(k,l,i)
9962 #endif
9963           enddo
9964           gsaxsC(l,i) = auxC - auxC1/Cnorm
9965 #ifdef ALLSAXS
9966           gsaxsX(l,i) = auxX - auxX1/Cnorm
9967 #endif
9968 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9969 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9970         enddo
9971       enddo
9972 #ifdef MPI
9973       endif
9974 #endif
9975       return
9976       end
9977 c----------------------------------------------------------------------------
9978       subroutine e_saxsC(Esaxs_constr)
9979       implicit none
9980       include 'DIMENSIONS'
9981 #ifdef MPI
9982       include "mpif.h"
9983       include "COMMON.SETUP"
9984       integer IERR
9985 #endif
9986       include 'COMMON.SBRIDGE'
9987       include 'COMMON.CHAIN'
9988       include 'COMMON.GEO'
9989       include 'COMMON.LOCAL'
9990       include 'COMMON.INTERACT'
9991       include 'COMMON.VAR'
9992       include 'COMMON.IOUNITS'
9993       include 'COMMON.DERIV'
9994       include 'COMMON.CONTROL'
9995       include 'COMMON.NAMES'
9996       include 'COMMON.FFIELD'
9997       include 'COMMON.LANGEVIN'
9998       include 'COMMON.SAXS'
9999 c
10000       double precision Esaxs_constr
10001       integer i,iint,j,k,l
10002       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
10003 #ifdef MPI
10004       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10005 #endif
10006       double precision dk,dijCASPH,dijSCSPH,
10007      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10008      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10009      & auxX,auxX1,Cnorm
10010 c  SAXS restraint penalty function
10011 #ifdef DEBUG
10012       write(iout,*) "------- SAXS penalty function start -------"
10013       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10014      & " isaxs_end",isaxs_end
10015       write (iout,*) "nnt",nnt," ntc",nct
10016       do i=nnt,nct
10017         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10018      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10019       enddo
10020       do i=nnt,nct
10021         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10022       enddo
10023 #endif
10024       Esaxs_constr = 0.0d0
10025       logPtot=0.0d0
10026       do j=isaxs_start,isaxs_end
10027         Pcalc_=0.0d0
10028         do i=1,nres
10029           do l=1,3
10030             PgradC(l,i)=0.0d0
10031             PgradX(l,i)=0.0d0
10032           enddo
10033         enddo
10034         do i=nnt,nct
10035           dijCASPH=0.0d0
10036           dijSCSPH=0.0d0
10037           do l=1,3
10038             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10039           enddo
10040           if (itype(i).ne.10) then
10041           do l=1,3
10042             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10043           enddo
10044           endif
10045           sigma2CA=2.0d0/pstok**2
10046           sigma2SC=4.0d0/restok(itype(i))**2
10047           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10048           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10049           Pcalc_ = Pcalc_+expCASPH+expSCSPH
10050 #ifdef DEBUG
10051           write(*,*) "processor i j Pcalc",
10052      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
10053 #endif
10054           CASPHgrad = sigma2CA*expCASPH
10055           SCSPHgrad = sigma2SC*expSCSPH
10056           do l=1,3
10057             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10058             PgradX(l,i) = PgradX(l,i) + aux
10059             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10060           enddo ! l
10061         enddo ! i
10062         do i=nnt,nct
10063           do l=1,3
10064             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
10065             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
10066           enddo
10067         enddo
10068         logPtot = logPtot - dlog(Pcalc_)
10069 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_),
10070 c     &    " logPtot",logPtot
10071       enddo ! j
10072 #ifdef MPI
10073       if (nfgtasks.gt.1) then
10074 c        write (iout,*) "logPtot before reduction",logPtot
10075         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10076      &    MPI_SUM,king,FG_COMM,IERR)
10077         logPtot = logPtot_
10078 c        write (iout,*) "logPtot after reduction",logPtot
10079         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10080      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10081         if (fg_rank.eq.king) then
10082           do i=1,nres
10083             do l=1,3
10084               gsaxsC(l,i) = gsaxsC_(l,i)
10085             enddo
10086           enddo
10087         endif
10088         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10089      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10090         if (fg_rank.eq.king) then
10091           do i=1,nres
10092             do l=1,3
10093               gsaxsX(l,i) = gsaxsX_(l,i)
10094             enddo
10095           enddo
10096         endif
10097       endif
10098 #endif
10099       Esaxs_constr = logPtot
10100       return
10101       end
10102 C--------------------------------------------------------------------------
10103 c MODELLER restraint function
10104       subroutine e_modeller(ehomology_constr)
10105       implicit real*8 (a-h,o-z)
10106       include 'DIMENSIONS'
10107       integer nnn, i, j, k, ki, irec, l
10108       integer katy, odleglosci, test7
10109       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
10110       real*8 distance(max_template),distancek(max_template),
10111      &    min_odl,godl(max_template),dih_diff(max_template)
10112
10113 c
10114 c     FP - 30/10/2014 Temporary specifications for homology restraints
10115 c
10116       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
10117      &                 sgtheta
10118       double precision, dimension (maxres) :: guscdiff,usc_diff
10119       double precision, dimension (max_template) ::
10120      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
10121      &           theta_diff
10122
10123       include 'COMMON.SBRIDGE'
10124       include 'COMMON.CHAIN'
10125       include 'COMMON.GEO'
10126       include 'COMMON.DERIV'
10127       include 'COMMON.LOCAL'
10128       include 'COMMON.INTERACT'
10129       include 'COMMON.VAR'
10130       include 'COMMON.IOUNITS'
10131       include 'COMMON.CONTROL'
10132       include 'COMMON.HOMRESTR'
10133       include 'COMMON.HOMOLOGY'
10134       include 'COMMON.SETUP'
10135       include 'COMMON.NAMES'
10136
10137       do i=1,max_template
10138         distancek(i)=9999999.9
10139       enddo
10140
10141       odleg=0.0d0
10142
10143 c Pseudo-energy and gradient from homology restraints (MODELLER-like
10144 c function)
10145 C AL 5/2/14 - Introduce list of restraints
10146 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
10147 #ifdef DEBUG
10148       write(iout,*) "------- dist restrs start -------"
10149 #endif
10150       do ii = link_start_homo,link_end_homo
10151          i = ires_homo(ii)
10152          j = jres_homo(ii)
10153          dij=dist(i,j)
10154 c        write (iout,*) "dij(",i,j,") =",dij
10155          nexl=0
10156          do k=1,constr_homology
10157            if(.not.l_homo(k,ii)) then
10158               nexl=nexl+1
10159               cycle
10160            endif
10161            distance(k)=odl(k,ii)-dij
10162 c          write (iout,*) "distance(",k,") =",distance(k)
10163 c
10164 c          For Gaussian-type Urestr
10165 c
10166            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
10167 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
10168 c          write (iout,*) "distancek(",k,") =",distancek(k)
10169 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
10170 c
10171 c          For Lorentzian-type Urestr
10172 c
10173            if (waga_dist.lt.0.0d0) then
10174               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
10175               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
10176      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
10177            endif
10178          enddo
10179
10180 c         min_odl=minval(distancek)
10181          do kk=1,constr_homology
10182           if(l_homo(kk,ii)) then
10183             min_odl=distancek(kk)
10184             exit
10185           endif
10186          enddo
10187          do kk=1,constr_homology
10188           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
10189      &              min_odl=distancek(kk)
10190          enddo
10191 c        write (iout,* )"min_odl",min_odl
10192 #ifdef DEBUG
10193          write (iout,*) "ij dij",i,j,dij
10194          write (iout,*) "distance",(distance(k),k=1,constr_homology)
10195          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
10196          write (iout,* )"min_odl",min_odl
10197 #endif
10198 #ifdef OLDRESTR
10199          odleg2=0.0d0
10200 #else
10201          if (waga_dist.ge.0.0d0) then
10202            odleg2=nexl
10203          else
10204            odleg2=0.0d0
10205          endif
10206 #endif
10207          do k=1,constr_homology
10208 c Nie wiem po co to liczycie jeszcze raz!
10209 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
10210 c     &              (2*(sigma_odl(i,j,k))**2))
10211            if(.not.l_homo(k,ii)) cycle
10212            if (waga_dist.ge.0.0d0) then
10213 c
10214 c          For Gaussian-type Urestr
10215 c
10216             godl(k)=dexp(-distancek(k)+min_odl)
10217             odleg2=odleg2+godl(k)
10218 c
10219 c          For Lorentzian-type Urestr
10220 c
10221            else
10222             odleg2=odleg2+distancek(k)
10223            endif
10224
10225 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
10226 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
10227 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
10228 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
10229
10230          enddo
10231 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10232 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10233 #ifdef DEBUG
10234          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
10235          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
10236 #endif
10237            if (waga_dist.ge.0.0d0) then
10238 c
10239 c          For Gaussian-type Urestr
10240 c
10241               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
10242 c
10243 c          For Lorentzian-type Urestr
10244 c
10245            else
10246               odleg=odleg+odleg2/constr_homology
10247            endif
10248 c
10249 #ifdef GRAD
10250 c        write (iout,*) "odleg",odleg ! sum of -ln-s
10251 c Gradient
10252 c
10253 c          For Gaussian-type Urestr
10254 c
10255          if (waga_dist.ge.0.0d0) sum_godl=odleg2
10256          sum_sgodl=0.0d0
10257          do k=1,constr_homology
10258 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10259 c     &           *waga_dist)+min_odl
10260 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
10261 c
10262          if(.not.l_homo(k,ii)) cycle
10263          if (waga_dist.ge.0.0d0) then
10264 c          For Gaussian-type Urestr
10265 c
10266            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
10267 c
10268 c          For Lorentzian-type Urestr
10269 c
10270          else
10271            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
10272      &           sigma_odlir(k,ii)**2)**2)
10273          endif
10274            sum_sgodl=sum_sgodl+sgodl
10275
10276 c            sgodl2=sgodl2+sgodl
10277 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
10278 c      write(iout,*) "constr_homology=",constr_homology
10279 c      write(iout,*) i, j, k, "TEST K"
10280          enddo
10281          if (waga_dist.ge.0.0d0) then
10282 c
10283 c          For Gaussian-type Urestr
10284 c
10285             grad_odl3=waga_homology(iset)*waga_dist
10286      &                *sum_sgodl/(sum_godl*dij)
10287 c
10288 c          For Lorentzian-type Urestr
10289 c
10290          else
10291 c Original grad expr modified by analogy w Gaussian-type Urestr grad
10292 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
10293             grad_odl3=-waga_homology(iset)*waga_dist*
10294      &                sum_sgodl/(constr_homology*dij)
10295          endif
10296 c
10297 c        grad_odl3=sum_sgodl/(sum_godl*dij)
10298
10299
10300 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
10301 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
10302 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
10303
10304 ccc      write(iout,*) godl, sgodl, grad_odl3
10305
10306 c          grad_odl=grad_odl+grad_odl3
10307
10308          do jik=1,3
10309             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
10310 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
10311 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
10312 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10313             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
10314             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
10315 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
10316 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
10317 c         if (i.eq.25.and.j.eq.27) then
10318 c         write(iout,*) "jik",jik,"i",i,"j",j
10319 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
10320 c         write(iout,*) "grad_odl3",grad_odl3
10321 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
10322 c         write(iout,*) "ggodl",ggodl
10323 c         write(iout,*) "ghpbc(",jik,i,")",
10324 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
10325 c     &                 ghpbc(jik,j)
10326 c         endif
10327          enddo
10328 #endif
10329 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
10330 ccc     & dLOG(odleg2),"-odleg=", -odleg
10331
10332       enddo ! ii-loop for dist
10333 #ifdef DEBUG
10334       write(iout,*) "------- dist restrs end -------"
10335 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
10336 c    &     waga_d.eq.1.0d0) call sum_gradient
10337 #endif
10338 c Pseudo-energy and gradient from dihedral-angle restraints from
10339 c homology templates
10340 c      write (iout,*) "End of distance loop"
10341 c      call flush(iout)
10342       kat=0.0d0
10343 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
10344 #ifdef DEBUG
10345       write(iout,*) "------- dih restrs start -------"
10346       do i=idihconstr_start_homo,idihconstr_end_homo
10347         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
10348       enddo
10349 #endif
10350       do i=idihconstr_start_homo,idihconstr_end_homo
10351         kat2=0.0d0
10352 c        betai=beta(i,i+1,i+2,i+3)
10353         betai = phi(i)
10354 c       write (iout,*) "betai =",betai
10355         do k=1,constr_homology
10356           dih_diff(k)=pinorm(dih(k,i)-betai)
10357 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
10358 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
10359 c     &                                   -(6.28318-dih_diff(i,k))
10360 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
10361 c     &                                   6.28318+dih_diff(i,k)
10362 #ifdef OLD_DIHED
10363           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
10364 #else
10365           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
10366 #endif
10367 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
10368           gdih(k)=dexp(kat3)
10369           kat2=kat2+gdih(k)
10370 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
10371 c          write(*,*)""
10372         enddo
10373 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
10374 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
10375 #ifdef DEBUG
10376         write (iout,*) "i",i," betai",betai," kat2",kat2
10377         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
10378 #endif
10379         if (kat2.le.1.0d-14) cycle
10380         kat=kat-dLOG(kat2/constr_homology)
10381 c       write (iout,*) "kat",kat ! sum of -ln-s
10382
10383 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
10384 ccc     & dLOG(kat2), "-kat=", -kat
10385
10386 #ifdef GRAD
10387 c ----------------------------------------------------------------------
10388 c Gradient
10389 c ----------------------------------------------------------------------
10390
10391         sum_gdih=kat2
10392         sum_sgdih=0.0d0
10393         do k=1,constr_homology
10394 #ifdef OLD_DIHED
10395           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
10396 #else
10397           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
10398 #endif
10399 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
10400           sum_sgdih=sum_sgdih+sgdih
10401         enddo
10402 c       grad_dih3=sum_sgdih/sum_gdih
10403         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
10404
10405 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
10406 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
10407 ccc     & gloc(nphi+i-3,icg)
10408         gloc(i,icg)=gloc(i,icg)+grad_dih3
10409 c        if (i.eq.25) then
10410 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
10411 c        endif
10412 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
10413 ccc     & gloc(nphi+i-3,icg)
10414 #endif
10415       enddo ! i-loop for dih
10416 #ifdef DEBUG
10417       write(iout,*) "------- dih restrs end -------"
10418 #endif
10419
10420 c Pseudo-energy and gradient for theta angle restraints from
10421 c homology templates
10422 c FP 01/15 - inserted from econstr_local_test.F, loop structure
10423 c adapted
10424
10425 c
10426 c     For constr_homology reference structures (FP)
10427 c
10428 c     Uconst_back_tot=0.0d0
10429       Eval=0.0d0
10430       Erot=0.0d0
10431 c     Econstr_back legacy
10432 #ifdef GRAD
10433       do i=1,nres
10434 c     do i=ithet_start,ithet_end
10435        dutheta(i)=0.0d0
10436 c     enddo
10437 c     do i=loc_start,loc_end
10438         do j=1,3
10439           duscdiff(j,i)=0.0d0
10440           duscdiffx(j,i)=0.0d0
10441         enddo
10442       enddo
10443 #endif
10444 c
10445 c     do iref=1,nref
10446 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
10447 c     write (iout,*) "waga_theta",waga_theta
10448       if (waga_theta.gt.0.0d0) then
10449 #ifdef DEBUG
10450       write (iout,*) "usampl",usampl
10451       write(iout,*) "------- theta restrs start -------"
10452 c     do i=ithet_start,ithet_end
10453 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
10454 c     enddo
10455 #endif
10456 c     write (iout,*) "maxres",maxres,"nres",nres
10457
10458       do i=ithet_start,ithet_end
10459 c
10460 c     do i=1,nfrag_back
10461 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
10462 c
10463 c Deviation of theta angles wrt constr_homology ref structures
10464 c
10465         utheta_i=0.0d0 ! argument of Gaussian for single k
10466         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10467 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
10468 c       over residues in a fragment
10469 c       write (iout,*) "theta(",i,")=",theta(i)
10470         do k=1,constr_homology
10471 c
10472 c         dtheta_i=theta(j)-thetaref(j,iref)
10473 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
10474           theta_diff(k)=thetatpl(k,i)-theta(i)
10475 c
10476           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
10477 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
10478           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
10479           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
10480 c         Gradient for single Gaussian restraint in subr Econstr_back
10481 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
10482 c
10483         enddo
10484 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
10485 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
10486
10487 c
10488 #ifdef GRAD
10489 c         Gradient for multiple Gaussian restraint
10490         sum_gtheta=gutheta_i
10491         sum_sgtheta=0.0d0
10492         do k=1,constr_homology
10493 c        New generalized expr for multiple Gaussian from Econstr_back
10494          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
10495 c
10496 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
10497           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
10498         enddo
10499 c
10500 c       Final value of gradient using same var as in Econstr_back
10501         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
10502      &               *waga_homology(iset)
10503 c       dutheta(i)=sum_sgtheta/sum_gtheta
10504 c
10505 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
10506 #endif
10507         Eval=Eval-dLOG(gutheta_i/constr_homology)
10508 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
10509 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
10510 c       Uconst_back=Uconst_back+utheta(i)
10511       enddo ! (i-loop for theta)
10512 #ifdef DEBUG
10513       write(iout,*) "------- theta restrs end -------"
10514 #endif
10515       endif
10516 c
10517 c Deviation of local SC geometry
10518 c
10519 c Separation of two i-loops (instructed by AL - 11/3/2014)
10520 c
10521 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
10522 c     write (iout,*) "waga_d",waga_d
10523
10524 #ifdef DEBUG
10525       write(iout,*) "------- SC restrs start -------"
10526       write (iout,*) "Initial duscdiff,duscdiffx"
10527       do i=loc_start,loc_end
10528         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
10529      &                 (duscdiffx(jik,i),jik=1,3)
10530       enddo
10531 #endif
10532       do i=loc_start,loc_end
10533         usc_diff_i=0.0d0 ! argument of Gaussian for single k
10534         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
10535 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
10536 c       write(iout,*) "xxtab, yytab, zztab"
10537 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
10538         do k=1,constr_homology
10539 c
10540           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10541 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
10542           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10543           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10544 c         write(iout,*) "dxx, dyy, dzz"
10545 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10546 c
10547           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
10548 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
10549 c         uscdiffk(k)=usc_diff(i)
10550           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
10551           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
10552 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
10553 c     &      xxref(j),yyref(j),zzref(j)
10554         enddo
10555 c
10556 c       Gradient
10557 c
10558 c       Generalized expression for multiple Gaussian acc to that for a single
10559 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
10560 c
10561 c       Original implementation
10562 c       sum_guscdiff=guscdiff(i)
10563 c
10564 c       sum_sguscdiff=0.0d0
10565 c       do k=1,constr_homology
10566 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
10567 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
10568 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
10569 c       enddo
10570 c
10571 c       Implementation of new expressions for gradient (Jan. 2015)
10572 c
10573 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
10574 #ifdef GRAD
10575         do k=1,constr_homology
10576 c
10577 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
10578 c       before. Now the drivatives should be correct
10579 c
10580           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
10581 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
10582           dyy=-yytpl(k,i)+yytab(i) ! ibid y
10583           dzz=-zztpl(k,i)+zztab(i) ! ibid z
10584 c
10585 c         New implementation
10586 c
10587           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
10588      &                 sigma_d(k,i) ! for the grad wrt r'
10589 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
10590 c
10591 c
10592 c        New implementation
10593          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
10594          do jik=1,3
10595             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
10596      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
10597      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
10598             duscdiff(jik,i)=duscdiff(jik,i)+
10599      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
10600      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
10601             duscdiffx(jik,i)=duscdiffx(jik,i)+
10602      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
10603      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
10604 c
10605 #ifdef DEBUG
10606              write(iout,*) "jik",jik,"i",i
10607              write(iout,*) "dxx, dyy, dzz"
10608              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
10609              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
10610 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
10611 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
10612 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
10613 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
10614 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
10615 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
10616 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
10617 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
10618 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
10619 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
10620 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
10621 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
10622 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
10623 c            endif
10624 #endif
10625          enddo
10626         enddo
10627 #endif
10628 c
10629 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
10630 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
10631 c
10632 c        write (iout,*) i," uscdiff",uscdiff(i)
10633 c
10634 c Put together deviations from local geometry
10635
10636 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
10637 c      &            wfrag_back(3,i,iset)*uscdiff(i)
10638         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
10639 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
10640 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
10641 c       Uconst_back=Uconst_back+usc_diff(i)
10642 c
10643 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
10644 c
10645 c     New implment: multiplied by sum_sguscdiff
10646 c
10647
10648       enddo ! (i-loop for dscdiff)
10649
10650 c      endif
10651
10652 #ifdef DEBUG
10653       write(iout,*) "------- SC restrs end -------"
10654         write (iout,*) "------ After SC loop in e_modeller ------"
10655         do i=loc_start,loc_end
10656          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
10657          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
10658         enddo
10659       if (waga_theta.eq.1.0d0) then
10660       write (iout,*) "in e_modeller after SC restr end: dutheta"
10661       do i=ithet_start,ithet_end
10662         write (iout,*) i,dutheta(i)
10663       enddo
10664       endif
10665       if (waga_d.eq.1.0d0) then
10666       write (iout,*) "e_modeller after SC loop: duscdiff/x"
10667       do i=1,nres
10668         write (iout,*) i,(duscdiff(j,i),j=1,3)
10669         write (iout,*) i,(duscdiffx(j,i),j=1,3)
10670       enddo
10671       endif
10672 #endif
10673
10674 c Total energy from homology restraints
10675 #ifdef DEBUG
10676       write (iout,*) "odleg",odleg," kat",kat
10677       write (iout,*) "odleg",odleg," kat",kat
10678       write (iout,*) "Eval",Eval," Erot",Erot
10679       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
10680       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
10681       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
10682 #endif
10683 c
10684 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
10685 c
10686 c     ehomology_constr=odleg+kat
10687 c
10688 c     For Lorentzian-type Urestr
10689 c
10690
10691       if (waga_dist.ge.0.0d0) then
10692 c
10693 c          For Gaussian-type Urestr
10694 c
10695 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
10696 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10697         ehomology_constr=waga_dist*odleg+waga_angle*kat+
10698      &              waga_theta*Eval+waga_d*Erot
10699 c     write (iout,*) "ehomology_constr=",ehomology_constr
10700       else
10701 c
10702 c          For Lorentzian-type Urestr
10703 c
10704 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
10705 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
10706         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
10707      &              waga_theta*Eval+waga_d*Erot
10708 c     write (iout,*) "ehomology_constr=",ehomology_constr
10709       endif
10710 #ifdef DEBUG
10711       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
10712      & "Eval",waga_theta,eval,
10713      &   "Erot",waga_d,Erot
10714       write (iout,*) "ehomology_constr",ehomology_constr
10715 #endif
10716       return
10717
10718   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
10719   747 format(a12,i4,i4,i4,f8.3,f8.3)
10720   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
10721   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
10722   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
10723      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
10724       end